diff --git a/.hgignore b/.hgignore
index 4063df2c04315693204c0b80e07ff23193b6ab83..e3a456fa1d076b0a5cdeeeb5151af3f7b9e8d4e2 100644
--- a/.hgignore
+++ b/.hgignore
@@ -91,3 +91,4 @@ findbugs.html
com.oracle.truffle.r.native/builtinlibs/lib/*/librfficall.*
com.oracle.truffle.r.native/builtinlibs/lib/*/libR.dylib
com.oracle.truffle.r.native/library/*/lib/*/*.*
+com.oracle.truffle.r.native/library/fastr/lib/*
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/REngine.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/REngine.java
index b1ea6439fb888469a3425427fe0aba72501fb781..b3949db9645710759523da373ffc0302b93dbf82 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/REngine.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/REngine.java
@@ -141,12 +141,7 @@ public final class REngine implements RContext.Engine {
*/
checkAndRunStartupFunction(".First");
checkAndRunStartupFunction(".First.sys");
- /*
- * TODO The following calls will eventually go away as this will be done in the system
- * profile
- */
- REnvironment.packagesInitialize((RStringVector) ROptions.getValue("defaultPackages"));
- RPackageVariables.initialize(); // TODO replace with R code
+ REnvironment.defaultPackagesInitialized();
initialized = true;
}
registerBaseGraphicsSystem();
diff --git a/com.oracle.truffle.r.native/fficall/jni/src/rfficall.c b/com.oracle.truffle.r.native/fficall/jni/src/rfficall.c
index 49cd8cd2a79a8cbece1ee5f7313d8f24720db351..6463f6af291d2500c5e69105f6099d90be571155 100644
--- a/com.oracle.truffle.r.native/fficall/jni/src/rfficall.c
+++ b/com.oracle.truffle.r.native/fficall/jni/src/rfficall.c
@@ -5,7 +5,7 @@
*
* Copyright (c) 1995-2012, The R Core Team
* Copyright (c) 2003, The R Foundation
- * Copyright (c) 2014, Oracle and/or its affiliates
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates
*
* All rights reserved.
*/
@@ -46,6 +46,7 @@ static jmethodID createDoubleArrayMethodID;
static jmethodID getIntDataAtZeroID;
static jmethodID getDoubleDataAtZeroID;
static jmethodID registerRoutinesID;
+static jmethodID registerCCallableID;
static jmethodID useDynamicSymbolsID;
static jmethodID forceSymbolsID;
static jmethodID setDotSymbolValuesID;
@@ -67,6 +68,7 @@ Java_com_oracle_truffle_r_runtime_ffi_jnr_CallRFFIWithJNI_initialize(JNIEnv *env
getIntDataAtZeroID = checkGetMethodID(env, CallRFFIHelperClass, "getIntDataAtZero", "(Ljava/lang/Object;)I", 1);
getDoubleDataAtZeroID = checkGetMethodID(env, CallRFFIHelperClass, "getDoubleDataAtZero", "(Ljava/lang/Object;)D", 1);
registerRoutinesID = checkGetMethodID(env, DLLClass, "registerRoutines", "(Lcom/oracle/truffle/r/runtime/ffi/DLL$DLLInfo;IIJ)V", 1);
+ registerCCallableID = checkGetMethodID(env, DLLClass, "registerCCallable", "(Ljava/lang/String;Ljava/lang/String;J)V", 1);
useDynamicSymbolsID = checkGetMethodID(env, DLLClass, "useDynamicSymbols", "(Lcom/oracle/truffle/r/runtime/ffi/DLL$DLLInfo;I)I", 1);
forceSymbolsID = checkGetMethodID(env, DLLClass, "forceSymbols", "(Lcom/oracle/truffle/r/runtime/ffi/DLL$DLLInfo;I)I", 1);
setDotSymbolValuesID = checkGetMethodID(env, DLLClass, "setDotSymbolValues", "(Ljava/lang/String;JI)Lcom/oracle/truffle/r/runtime/ffi/DLL$DotSymbol;", 1);
@@ -83,7 +85,8 @@ R_registerRoutines(DllInfo *info, const R_CMethodDef * const croutines,
const R_CallMethodDef * const callRoutines,
const R_FortranMethodDef * const fortranRoutines,
const R_ExternalMethodDef * const externalRoutines) {
- // To avoid callbacks to convert the data in the R_CallMethodDef piece by piece, create it here.
+ // In theory we could create all the data here and pass it up, but in practice there were inexplicable
+ // Hotspot SEGV crashes creating Java arrays and Java objects in this function
JNIEnv *thisenv = getEnv();
int num;
if (croutines) {
@@ -105,6 +108,14 @@ R_registerRoutines(DllInfo *info, const R_CMethodDef * const croutines,
return 1;
}
+void R_RegisterCCallable(const char *package, const char *name, DL_FUNC fptr) {
+ JNIEnv *thisenv = getEnv();
+// printf("pkgname %s, name %s\n", package, name);
+ jstring packageString = (*thisenv)->NewStringUTF(thisenv, package);
+ jstring nameString = (*thisenv)->NewStringUTF(thisenv, name);
+ (*thisenv)->CallStaticVoidMethod(thisenv, DLLClass, registerCCallableID, packageString, nameString, fptr);
+}
+
JNIEXPORT jobject JNICALL
Java_com_oracle_truffle_r_runtime_ffi_DLL_setSymbol(JNIEnv *env, jclass c, jint nstOrd, jlong routinesAddr, jint index) {
const char *name;
@@ -131,6 +142,7 @@ Java_com_oracle_truffle_r_runtime_ffi_DLL_setSymbol(JNIEnv *env, jclass c, jint
name = fortranRoutines[index].name;
fun = (long) fortranRoutines[index].fun;
numArgs = fortranRoutines[index].numArgs;
+ break;
}
case EXTERNAL_NATIVE_TYPE: {
R_ExternalMethodDef * externalRoutines = (R_ExternalMethodDef *) routinesAddr;
@@ -139,7 +151,7 @@ Java_com_oracle_truffle_r_runtime_ffi_DLL_setSymbol(JNIEnv *env, jclass c, jint
numArgs = externalRoutines[index].numArgs;
break;
}
- default: (*env)->FatalError(env, "NativeSynbolTyope out of range");
+ default: (*env)->FatalError(env, "NativeSymbolType out of range");
}
// printf("name %s, fun %0lx, numArgs %d\n", name, fun, numArgs);
jstring nameString = (*env)->NewStringUTF(env, name);
diff --git a/com.oracle.truffle.r.native/library/Makefile b/com.oracle.truffle.r.native/library/Makefile
index 29a754a9b61e888a56d5e9d47d16863e286e6d24..0f0054c2a1a3f7ac3ed3e085bef360f56d55f237 100644
--- a/com.oracle.truffle.r.native/library/Makefile
+++ b/com.oracle.truffle.r.native/library/Makefile
@@ -23,7 +23,7 @@
.PHONY: all clean libdir make_subdirs clean_subdirs
-SUBDIRS = datasets utils grDevices graphics stats methods tools
+SUBDIRS = datasets utils grDevices graphics stats methods tools fastr
export FASTR_LIBDIR = $(TOPDIR)/../library
all: libdir make_subdirs
diff --git a/com.oracle.truffle.r.native/library/README b/com.oracle.truffle.r.native/library/README
new file mode 100644
index 0000000000000000000000000000000000000000..ff0732e186a54ec948e7fafdb6c3579375b5f2c1
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/README
@@ -0,0 +1,10 @@
+This directory tree contains the default packages for FastR. Each package directory contains a '.gz' file that was
+created from the corresponding GnuR 'library' directory, plus necessary C source and header files, most notably 'init.c',
+also copied from GnuR. Since these files reference functions in the GnuR implementation, 'init.c' is recompiled
+in the FastR environment and the resulting '.so' replaces the one from the '.gz' file in the FastR 'library' directory.
+Absolutely minimal changes are made to the C source, typically just to define (as empty functions), rather than reference,
+the C functions that are passed to R_registerRoutines. This step is still necesssary in FastR as it causes R symbols that are'
+referenced in the R package code to become defined.
+
+Note that 'datasets' and 'fastr' don't actually have any native code, but it is convenient to store them here. Note also that
+'fastr', obviously, does not originate from GnuR, so its build process is completely different.
diff --git a/com.oracle.truffle.r.native/library/fastr/Makefile b/com.oracle.truffle.r.native/library/fastr/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..b9b0c6435232c9afeab20c2e964156f051aef278
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/Makefile
@@ -0,0 +1,49 @@
+#
+# Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+# This "builds" the "fastr" package, which defines functions that can
+# access the internals of the FastR implementation, e.g., print Truffle ASTs.
+# It is a "real" package, and loaded in the same way as any R package.
+
+# We use a 'tar' file of the sources as the sentinel for whether the INSTALL step is needed
+# Since this is just R code, we use GnuR to do the INSTALL
+
+.PHONY: all
+
+PKG_FILES = $(shell find src/ -type f -name '*')
+INSTALL_SENTINEL = $(FASTR_LIBDIR)/fastr/DESCRIPTION
+
+PKG_TAR = lib/fastr.tar
+
+all: $(INSTALL_SENTINEL)
+
+$(PKG_TAR): $(PKG_FILES)
+ mkdir -p lib
+ (cd src; tar cf ../$(PKG_TAR) *)
+
+$(INSTALL_SENTINEL): $(PKG_TAR)
+ R CMD INSTALL --library=$(FASTR_LIBDIR) src
+
+clean:
+ rm -f $(PKG_TAR)
+
diff --git a/com.oracle.truffle.r.native/library/fastr/src/DESCRIPTION b/com.oracle.truffle.r.native/library/fastr/src/DESCRIPTION
new file mode 100644
index 0000000000000000000000000000000000000000..965baccd7261937ef6fabcfcf0ee1f567089e8ac
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/src/DESCRIPTION
@@ -0,0 +1,10 @@
+Package: fastr
+Type: Package
+Title: Functions for interacting with the FastR implementation
+Version: 1.0
+Date: 2015-02-05
+Author: FastR
+Maintainer: FastR <fastr@yahoogroups.com>
+Description: Functions for interacting with the FastR implementation
+License: GPL-2
+Packaged: 2014-02-05 22:48:32 UTC;
\ No newline at end of file
diff --git a/com.oracle.truffle.r.native/library/fastr/src/NAMESPACE b/com.oracle.truffle.r.native/library/fastr/src/NAMESPACE
new file mode 100644
index 0000000000000000000000000000000000000000..2cfc7539b7b8db10ee592d3f7b22094297854998
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/src/NAMESPACE
@@ -0,0 +1,11 @@
+## exported functions
+export(fastr.createcc)
+export(fastr.getcc)
+export(fastr.compile)
+export(fastr.dumptrees)
+export(fastr.source)
+export(fastr.stacktrace)
+export(fastr.syntaxtree)
+export(fastr.seqlengths)
+export(fastr.tree)
+export(fastr.typeof)
diff --git a/com.oracle.truffle.r.native/library/fastr/src/R/fastr.R b/com.oracle.truffle.r.native/library/fastr/src/R/fastr.R
new file mode 100644
index 0000000000000000000000000000000000000000..484f91baf83a6b5a7f7b4b93a40ee55990c21257
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/src/R/fastr.R
@@ -0,0 +1,43 @@
+#
+# Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+fastr.createcc <- function(func) .FastR(.NAME="createcc", func)
+
+fastr.getcc <- function(func) .FastR(.NAME="getcc", func)
+
+fastr.compile <- function(func, background=TRUE) .FastR(.NAME="getcc", func, background)
+
+fastr.dumptrees <- function(func, igvDump=FALSE, verbose=FALSE) .FastR(.NAME="getcc", func, igvDump, verbose)
+
+fastr.source <- function(func) .FastR(.NAME="source", func)
+
+fastr.syntaxtree <- function(func) .FastR(.NAME="syntaxtree", func)
+
+fastr.tree <- function(func, verbose=FALSE) .FastR(.NAME="tree", func, verbose)
+
+fastr.seqlengths <- function(func) .FastR(.NAME="seqlengths", func)
+
+fastr.typeof <- function(x) .FastR(.NAME="typeof", x)
+
+fastr.stacktrace <- function(print.frame.contents=TRUE) .FastR(.NAME="stacktrace", print.frame.contents)
+
diff --git a/com.oracle.truffle.r.native/library/fastr/src/man/fastr-package.Rd b/com.oracle.truffle.r.native/library/fastr/src/man/fastr-package.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..9dadfc8c6ea441bf2571308bfd91c00891ed6277
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/src/man/fastr-package.Rd
@@ -0,0 +1,31 @@
+\name{fastr-package}
+\alias{fastr-package}
+\alias{fastr}
+\docType{package}
+\title{Functions for interacting with the FastR implementation}
+\description{Functions for interacting with the FastR implementation}
+\details{
+\tabular{ll}{
+Package: \tab fastr\cr
+Type: \tab Package\cr
+Version: \tab 1.0\cr
+Date: \tab 2015-02-05\cr
+License: \tab GPL-2\cr
+}
+
+}
+\author{
+The FastR Team
+
+Maintainer: fastr@yahoogroups.com
+}
+\references{
+}
+
+\keyword{ package }
+\seealso{
+
+}
+\examples{
+
+}
diff --git a/com.oracle.truffle.r.native/library/fastr/src/man/fastr.Rd b/com.oracle.truffle.r.native/library/fastr/src/man/fastr.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..84d5d55498c7e21652a31c16faa755da24102f1d
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/fastr/src/man/fastr.Rd
@@ -0,0 +1,35 @@
+\name{fastr}
+\alias{fastr}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+fastr
+}
+\description{
+Functions for interacting with the FastR implementation
+}
+\usage{
+fastr.compile(f)
+}
+
+\details{
+
+}
+\value{
+invisble NULL
+}
+\references{
+
+}
+\author{
+FastR Team
+}
+\note{
+
+}
+
+\seealso{
+%
+}
+\examples{
+fastr.compile(f)
+}
diff --git a/com.oracle.truffle.r.native/library/graphics/src/graphics.h b/com.oracle.truffle.r.native/library/graphics/src/graphics.h
new file mode 100644
index 0000000000000000000000000000000000000000..79c1ef3f1b04639c5c85b5a8eadeae324b26a091
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/graphics/src/graphics.h
@@ -0,0 +1,73 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2012 The R Core Team.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#undef _
+#define _(String) dgettext ("graphics", String)
+#else
+#define _(String) (String)
+#endif
+
+SEXP C_contour(SEXP args) { return NULL; }
+SEXP C_contourDef(void) { return NULL; }
+SEXP C_filledcontour(SEXP args) { return NULL; }
+SEXP C_image(SEXP args) { return NULL; }
+SEXP C_persp(SEXP args) { return NULL; }
+
+SEXP C_abline(SEXP args) { return NULL; }
+SEXP C_arrows(SEXP args) { return NULL; }
+SEXP C_axis(SEXP args) { return NULL; }
+SEXP C_box(SEXP args) { return NULL; }
+SEXP C_clip(SEXP args) { return NULL; }
+SEXP C_convertX(SEXP args) { return NULL; }
+SEXP C_convertY(SEXP args) { return NULL; }
+SEXP C_dend(SEXP args) { return NULL; }
+SEXP C_dendwindow(SEXP args) { return NULL; }
+SEXP C_erase(SEXP args) { return NULL; }
+SEXP C_layout(SEXP args) { return NULL; }
+SEXP C_mtext(SEXP args) { return NULL; }
+SEXP C_path(SEXP args) { return NULL; }
+SEXP C_plotXY(SEXP args) { return NULL; }
+SEXP C_plot_window(SEXP args) { return NULL; }
+SEXP C_polygon(SEXP args) { return NULL; }
+SEXP C_raster(SEXP args) { return NULL; }
+SEXP C_rect(SEXP args) { return NULL; }
+SEXP C_segments(SEXP args) { return NULL; }
+SEXP C_strHeight(SEXP args) { return NULL; }
+SEXP C_strWidth (SEXP args) { return NULL; }
+SEXP C_symbols(SEXP args) { return NULL; }
+SEXP C_text(SEXP args) { return NULL; }
+SEXP C_title(SEXP args) { return NULL; }
+SEXP C_xspline(SEXP args) { return NULL; }
+
+
+SEXP C_par(SEXP call, SEXP op, SEXP args, SEXP rho) { return NULL; }
+SEXP C_plot_new(SEXP call, SEXP op, SEXP args, SEXP rho) { return NULL; }
+SEXP C_locator(SEXP call, SEXP op, SEXP args, SEXP rho) { return NULL; }
+SEXP C_identify(SEXP call, SEXP op, SEXP args, SEXP rho) { return NULL; }
+
+void registerBase(void) { }
+void unregisterBase(void) { }
+SEXP RunregisterBase(void) { return NULL; }
+
+SEXP C_StemLeaf(SEXP x, SEXP scale, SEXP swidth, SEXP atom) { return NULL; }
+SEXP C_BinCount(SEXP x, SEXP breaks, SEXP right, SEXP lowest) { return NULL; }
+
+Rboolean isNAcol(SEXP col, int index, int ncol) { return FALSE; }
diff --git a/com.oracle.truffle.r.native/library/graphics/src/init.c b/com.oracle.truffle.r.native/library/graphics/src/init.c
new file mode 100644
index 0000000000000000000000000000000000000000..dfc6468c2877fe9c02cde700075d2d8554a08040
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/graphics/src/init.c
@@ -0,0 +1,93 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2012 The R Core Team.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include <R.h>
+#include <Rinternals.h>
+
+#include "graphics.h"
+#include <R_ext/Rdynload.h>
+
+#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
+
+static const R_CallMethodDef CallEntries[] = {
+ CALLDEF(C_contourDef, 0),
+ CALLDEF(C_StemLeaf, 4),
+ CALLDEF(C_BinCount, 4),
+ CALLDEF(RunregisterBase, 0),
+ {NULL, NULL, 0}
+};
+
+
+#define EXTDEF(name, n) {#name, (DL_FUNC) &name, n}
+
+static const R_ExternalMethodDef ExtEntries[] = {
+ EXTDEF(C_contour, -1),
+ EXTDEF(C_filledcontour, 5),
+ EXTDEF(C_image, 4),
+ EXTDEF(C_persp, -1),
+
+ EXTDEF(C_abline, -1),
+ EXTDEF(C_axis, -1),
+ EXTDEF(C_arrows, -1),
+ EXTDEF(C_box, -1),
+ EXTDEF(C_clip, -1),
+ EXTDEF(C_convertX, 3),
+ EXTDEF(C_convertY, 3),
+ EXTDEF(C_dend, -1),
+ EXTDEF(C_dendwindow, -1),
+ EXTDEF(C_erase, -1),
+ EXTDEF(C_layout, -1),
+ EXTDEF(C_mtext, -1),
+ EXTDEF(C_par, -1),
+ EXTDEF(C_path, -1),
+ EXTDEF(C_plotXY, -1),
+ EXTDEF(C_plot_window, -1),
+ EXTDEF(C_polygon, -1),
+ EXTDEF(C_raster, -1),
+ EXTDEF(C_rect, -1),
+ EXTDEF(C_segments, -1),
+ EXTDEF(C_strHeight, -1),
+ EXTDEF(C_strWidth, -1),
+ EXTDEF(C_symbols, -1),
+ EXTDEF(C_text, -1),
+ EXTDEF(C_title, -1),
+ EXTDEF(C_xspline, -1),
+
+ EXTDEF(C_plot_new, 0),
+ EXTDEF(C_locator, -1),
+ EXTDEF(C_identify, -1),
+ {NULL, NULL, 0}
+};
+
+
+void
+#ifdef HAVE_VISIBILITY_ATTRIBUTE
+__attribute__ ((visibility ("default")))
+#endif
+R_init_graphics(DllInfo *dll)
+{
+ R_registerRoutines(dll, NULL, CallEntries, NULL, ExtEntries);
+ R_useDynamicSymbols(dll, FALSE);
+ R_forceSymbols(dll, TRUE);
+ registerBase();
+}
diff --git a/com.oracle.truffle.r.native/library/lib.mk b/com.oracle.truffle.r.native/library/lib.mk
index e79a374d36ea602383be6822b2faabe6d131c1f0..64d2c5726715c8103e25f21b77a78fbbf29dda91 100644
--- a/com.oracle.truffle.r.native/library/lib.mk
+++ b/com.oracle.truffle.r.native/library/lib.mk
@@ -55,7 +55,11 @@ INCLUDES := $(JNI_INCLUDES) $(FFI_INCLUDES)
PKGDIR := $(FASTR_LIBDIR)/$(PKG)
PKGTAR := $(SRC)/$(PKG).tar.gz
+ifneq ($(C_SOURCES),)
all: libcommon $(LIB_PKG)
+else
+all: libcommon
+endif
libcommon: $(PKGDIR)
diff --git a/com.oracle.truffle.r.native/library/stats/src/nls.h b/com.oracle.truffle.r.native/library/stats/src/nls.h
index 069146fb723e47e5a86a62cc3ea772da38f841c9..50344e7b15801490b73a1031b27e86368f741c41 100644
--- a/com.oracle.truffle.r.native/library/stats/src/nls.h
+++ b/com.oracle.truffle.r.native/library/stats/src/nls.h
@@ -24,7 +24,7 @@
#define _(String) (String)
#endif
-SEXP nls_iter(SEXP m, SEXP control, SEXP doTraceArg);
-SEXP numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir);
+SEXP nls_iter(SEXP m, SEXP control, SEXP doTraceArg) { return NULL; }
+SEXP numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir) { return NULL; }
diff --git a/com.oracle.truffle.r.native/library/utils/src/utils.c b/com.oracle.truffle.r.native/library/utils/src/utils.c
deleted file mode 100644
index fab17ac780e37516a47cc8b0310cae7caa3a1baf..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/utils/src/utils.c
+++ /dev/null
@@ -1 +0,0 @@
-// Empty file
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/RBuiltinPackages.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/RBuiltinPackages.java
index 054b2feb08b316187a2a5069e3d66a8a39977ff3..b29fc496d08e126c01562d8068b504a171e65025 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/RBuiltinPackages.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/RBuiltinPackages.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -27,8 +27,6 @@ import java.util.*;
import com.oracle.truffle.api.*;
import com.oracle.truffle.api.frame.*;
import com.oracle.truffle.r.nodes.builtin.base.*;
-import com.oracle.truffle.r.nodes.builtin.fastr.*;
-import com.oracle.truffle.r.nodes.builtin.stats.*;
import com.oracle.truffle.r.options.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
@@ -49,8 +47,6 @@ public final class RBuiltinPackages implements RBuiltinLookup {
static {
RBuiltinPackages.add(new BasePackage());
- RBuiltinPackages.add(new FastRPackage());
- RBuiltinPackages.add(new StatsPackage());
}
protected static void add(RBuiltinPackage builtins) {
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/BaseGammaFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/BaseGammaFunctions.java
new file mode 100644
index 0000000000000000000000000000000000000000..fddec959924bd737db94887cc8bb250ced746470
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/BaseGammaFunctions.java
@@ -0,0 +1,568 @@
+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (C) 1998 Ross Ihaka
+ * Copyright (c) 1998--2012, The R Core Team
+ * Copyright (c) 2004, The R Foundation
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+package com.oracle.truffle.r.nodes.builtin.base;
+
+import static com.oracle.truffle.r.nodes.builtin.stats.StatsUtil.*;
+import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
+
+import com.oracle.truffle.api.*;
+import com.oracle.truffle.api.CompilerDirectives.*;
+import com.oracle.truffle.api.dsl.*;
+import com.oracle.truffle.api.frame.*;
+import com.oracle.truffle.r.nodes.*;
+import com.oracle.truffle.r.nodes.builtin.*;
+import com.oracle.truffle.r.nodes.builtin.base.BaseGammaFunctionsFactory.DpsiFnCalcNodeGen;
+import com.oracle.truffle.r.nodes.builtin.stats.*;
+import com.oracle.truffle.r.runtime.*;
+import com.oracle.truffle.r.runtime.data.*;
+import com.oracle.truffle.r.runtime.data.closures.*;
+import com.oracle.truffle.r.runtime.data.model.*;
+import com.oracle.truffle.r.runtime.ops.na.*;
+
+public class BaseGammaFunctions {
+ @RBuiltin(name = "lgamma", kind = PRIMITIVE, parameterNames = {"x"})
+ public abstract static class Lgamma extends RBuiltinNode {
+
+ private final NACheck naClosureCheck = NACheck.create();
+ private final NACheck naValCheck = NACheck.create();
+
+ @Specialization
+ protected RDoubleVector lgamma(RAbstractDoubleVector x) {
+ controlVisibility();
+ naValCheck.enable(true);
+ double[] result = new double[x.getLength()];
+ for (int i = 0; i < x.getLength(); ++i) {
+ double xv = x.getDataAt(i);
+ result[i] = GammaFunctions.lgammafn(xv);
+ naValCheck.check(result[i]);
+ }
+ return RDataFactory.createDoubleVector(result, naValCheck.neverSeenNA());
+ }
+
+ @Specialization
+ protected RDoubleVector lgamma(RAbstractIntVector x) {
+ return lgamma(RClosures.createIntToDoubleVector(x, naClosureCheck));
+ }
+
+ @Specialization
+ protected RDoubleVector lgamma(RAbstractLogicalVector x) {
+ return lgamma(RClosures.createLogicalToDoubleVector(x, naClosureCheck));
+ }
+
+ @Specialization
+ protected Object lgamma(@SuppressWarnings("unused") RAbstractComplexVector x) {
+ return RError.error(RError.Message.UNIMPLEMENTED_COMPLEX_FUN);
+ }
+
+ @Fallback
+ protected Object lgamma(@SuppressWarnings("unused") Object x) {
+ throw RError.error(RError.Message.NON_NUMERIC_MATH);
+ }
+
+ }
+
+ @RBuiltin(name = "digamma", kind = PRIMITIVE, parameterNames = {"x"})
+ public abstract static class DiGamma extends RBuiltinNode {
+
+ @Child DpsiFnCalc dpsiFnCalc;
+
+ private final NACheck naClosureCheck = NACheck.create();
+ private final NACheck naValCheck = NACheck.create();
+
+ private double dpsiFnCalc(VirtualFrame frame, double x, int n, int kode, double ans) {
+ if (dpsiFnCalc == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ dpsiFnCalc = insert(DpsiFnCalcNodeGen.create(null, null, null, null));
+ }
+ return dpsiFnCalc.executeDouble(frame, x, n, kode, ans);
+ }
+
+ @Specialization
+ protected RDoubleVector digamma(VirtualFrame frame, RAbstractDoubleVector x) {
+ controlVisibility();
+ naValCheck.enable(x);
+ double[] result = new double[x.getLength()];
+ boolean warnNaN = false;
+ for (int i = 0; i < x.getLength(); ++i) {
+ double xv = x.getDataAt(i);
+ if (naValCheck.check(xv)) {
+ result[i] = xv;
+ } else {
+ double val = dpsiFnCalc(frame, xv, 0, 1, 0);
+ if (Double.isNaN(val)) {
+ result[i] = val;
+ warnNaN = true;
+ } else {
+ result[i] = -val;
+ }
+ }
+ }
+ if (warnNaN) {
+ RError.warning(RError.Message.NAN_PRODUCED);
+ }
+ return RDataFactory.createDoubleVector(result, naValCheck.neverSeenNA());
+ }
+
+ @Specialization
+ protected RDoubleVector digamma(VirtualFrame frame, RAbstractIntVector x) {
+ return digamma(frame, RClosures.createIntToDoubleVector(x, naClosureCheck));
+ }
+
+ @Specialization
+ protected RDoubleVector digamma(VirtualFrame frame, RAbstractLogicalVector x) {
+ return digamma(frame, RClosures.createLogicalToDoubleVector(x, naClosureCheck));
+ }
+
+ @Specialization
+ protected Object digamma(@SuppressWarnings("unused") RAbstractComplexVector x) {
+ return RError.error(RError.Message.UNIMPLEMENTED_COMPLEX_FUN);
+ }
+
+ @Fallback
+ protected Object digamma(@SuppressWarnings("unused") Object x) {
+ throw RError.error(RError.Message.NON_NUMERIC_MATH);
+ }
+
+ }
+
+ @NodeChildren({@NodeChild(value = "x"), @NodeChild(value = "n"), @NodeChild(value = "kode"), @NodeChild(value = "ans")})
+ protected abstract static class DpsiFnCalc extends RNode {
+
+ // the following is transcribed from polygamma.c
+
+ public abstract double executeDouble(VirtualFrame frame, double x, int n, int kode, double ans);
+
+ @Child DpsiFnCalc dpsiFnCalc;
+
+ @CompilationFinal private static final double[] bvalues = new double[]{1.00000000000000000e+00, -5.00000000000000000e-01, 1.66666666666666667e-01, -3.33333333333333333e-02,
+ 2.38095238095238095e-02, -3.33333333333333333e-02, 7.57575757575757576e-02, -2.53113553113553114e-01, 1.16666666666666667e+00, -7.09215686274509804e+00,
+ 5.49711779448621554e+01, -5.29124242424242424e+02, 6.19212318840579710e+03, -8.65802531135531136e+04, 1.42551716666666667e+06, -2.72982310678160920e+07,
+ 6.01580873900642368e+08, -1.51163157670921569e+10, 4.29614643061166667e+11, -1.37116552050883328e+13, 4.88332318973593167e+14, -1.92965793419400681e+16};
+
+ private static final int n_max = 100;
+ // the following is actually a parameter in the original code, but it's always 1 and must be
+ // as the original code treats the "ans" value of type double as an array, which is legal
+ // only if a the first element of the array is accessed at all times
+ private static final int m = 1;
+
+ private double dpsiFnCalc(VirtualFrame frame, double x, int n, int kode, double ans) {
+ if (dpsiFnCalc == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ dpsiFnCalc = insert(DpsiFnCalcNodeGen.create(null, null, null, null));
+ }
+ return dpsiFnCalc.executeDouble(frame, x, n, kode, ans);
+ }
+
+ // TODO: it's recursive - turn into AST recursion
+ @Specialization
+ double dpsifn(VirtualFrame frame, double xOld, int n, int kode, double ansOld) {
+
+ double x = xOld;
+ double ans = ansOld;
+
+ int mm;
+ int mx;
+ int nn;
+ int np;
+ int nx;
+ int fn;
+ double arg;
+ double den;
+ double elim;
+ double eps;
+ double fln;
+ double rln;
+ double r1m4;
+ double r1m5;
+ double s;
+ double slope;
+ double t;
+ double tk;
+ double tt;
+ double t1;
+ double t2;
+ double wdtol;
+ double xdmln;
+ double xdmy;
+ double xinc;
+ double xln = 0.0;
+ double xm;
+ double xmin;
+ double yint;
+ double[] trm = new double[23];
+ double[] trmr = new double[n_max + 1];
+
+ // non-zero ierr always results in generating a NaN
+// mVal.ierr = 0;
+ if (n < 0 || kode < 1 || kode > 2 || m < 1) {
+ return Double.NaN;
+ }
+ if (x <= 0.) {
+ /*
+ * use Abramowitz & Stegun 6.4.7 "Reflection Formula" psi(k, x) = (-1)^k psi(k, 1-x)
+ * - pi^{n+1} (d/dx)^n cot(x)
+ */
+ if (x == Math.round(x)) {
+ /* non-positive integer : +Inf or NaN depends on n */
+// for(j=0; j < m; j++) /* k = j + n : */
+// ans[j] = ((j+n) % 2) ? ML_POSINF : ML_NAN;
+ // m is always 1
+ ans = (n % 2) != 0 ? Double.POSITIVE_INFINITY : Double.NaN;
+ return ans;
+ }
+ /* This could cancel badly */
+ ans = dpsiFnCalc(frame, 1. - x, n, /* kode = */1, ans);
+ /*
+ * ans[j] == (-1)^(k+1) / gamma(k+1) * psi(k, 1 - x) for j = 0:(m-1) , k = n + j
+ */
+
+ /* Cheat for now: only work for m = 1, n in {0,1,2,3} : */
+ if (m > 1 || n > 3) { /* doesn't happen for digamma() .. pentagamma() */
+ /* not yet implemented */
+ // non-zero ierr always results in generating a NaN
+// mVal.ierr = 4;
+ return Double.NaN;
+ }
+ x *= M_PI; /* pi * x */
+ if (n == 0) {
+ tt = Math.cos(x) / Math.sin(x);
+ } else if (n == 1) {
+ tt = -1 / Math.pow(Math.sin(x), 2);
+ } else if (n == 2) {
+ tt = 2 * Math.cos(x) / Math.pow(Math.sin(x), 3);
+ } else if (n == 3) {
+ tt = -2 * (2 * Math.pow(Math.cos(x), 2) + 1.) / Math.pow(Math.sin(x), 4);
+ } else { /* can not happen! */
+ tt = RRuntime.DOUBLE_NA;
+ }
+ /* end cheat */
+
+ s = (n % 2) != 0 ? -1. : 1.; /* s = (-1)^n */
+ /*
+ * t := pi^(n+1) * d_n(x) / gamma(n+1) , where d_n(x) := (d/dx)^n cot(x)
+ */
+ t1 = t2 = s = 1.;
+ for (int k = 0, j = k - n; j < m; k++, j++, s = -s) {
+ /* k == n+j , s = (-1)^k */
+ t1 *= M_PI; /* t1 == pi^(k+1) */
+ if (k >= 2) {
+ t2 *= k; /* t2 == k! == gamma(k+1) */
+ }
+ if (j >= 0) { /* by cheat above, tt === d_k(x) */
+ // j must always be 0
+ assert j == 0;
+// ans[j] = s*(ans[j] + t1/t2 * tt);
+ ans = s * (ans + t1 / t2 * tt);
+ }
+ }
+ if (n == 0 && kode == 2) { /* unused from R, but "wrong": xln === 0 : */
+// ans[0] += xln;
+ ans += xln;
+ }
+ return ans;
+ } /* x <= 0 */
+
+ /* else : x > 0 */
+ // nz not used
+// mVal.nz = 0;
+ xln = Math.log(x);
+ if (kode == 1 /* && m == 1 */) { /* the R case --- for very large x: */
+ double lrg = 1 / (2. * DBLEPSILON);
+ if (n == 0 && x * xln > lrg) {
+// ans[0] = -xln;
+ ans = -xln;
+ return ans;
+ } else if (n >= 1 && x > n * lrg) {
+// ans[0] = exp(-n * xln)/n; /* == x^-n / n == 1/(n * x^n) */
+ ans = Math.exp(-n * xln) / n;
+ return ans;
+ }
+ }
+ mm = m;
+ // nx = imin2(-Rf_i1mach(15), Rf_i1mach(16));/* = 1021 */
+ nx = Math.min(-DBL_MIN_EXP, DBL_MAX_EXP);
+ assert (nx == 1021);
+ r1m5 = M_LOG10_2; // Rf_d1mach(5);
+ r1m4 = DBLEPSILON * 0.5; // Rf_d1mach(4) * 0.5;
+ wdtol = fmax2(r1m4, 0.5e-18); /* 1.11e-16 */
+
+ /* elim = approximate exponential over and underflow limit */
+ elim = 2.302 * (nx * r1m5 - 3.0); /* = 700.6174... */
+ for (;;) {
+ nn = n + mm - 1;
+ fn = nn;
+ t = (fn + 1) * xln;
+
+ /* overflow and underflow test for small and large x */
+
+ if (Math.abs(t) > elim) {
+ if (t <= 0.0) {
+ // nz not used
+// mVal.nz = 0;
+ // non-zero ierr always results in generating a NaN
+// mVal.ierr = 2;
+ return Double.NaN;
+ }
+ } else {
+ if (x < wdtol) {
+// ans[0] = R_pow_di(x, -n-1);
+ ans = Math.pow(x, -n - 1);
+ if (mm != 1) {
+// for(k = 1; k < mm ; k++)
+// ans[k] = ans[k-1] / x;
+ assert mm < 2;
+ // int the original code, ans should not be accessed beyond the 0th
+// index
+ }
+ if (n == 0 && kode == 2) {
+// ans[0] += xln;
+ ans += xln;
+ }
+ return ans;
+ }
+
+ /* compute xmin and the number of terms of the series, fln+1 */
+
+ rln = r1m5 * DBL_MANT_DIG; // Rf_i1mach(14);
+ rln = Math.min(rln, 18.06);
+ fln = Math.max(rln, 3.0) - 3.0;
+ yint = 3.50 + 0.40 * fln;
+ slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
+ xm = yint + slope * fn;
+ mx = (int) xm + 1;
+ xmin = mx;
+ if (n != 0) {
+ xm = -2.302 * rln - Math.min(0.0, xln);
+ arg = xm / n;
+ arg = Math.min(0.0, arg);
+ eps = Math.exp(arg);
+ xm = 1.0 - eps;
+ if (Math.abs(arg) < 1.0e-3) {
+ xm = -arg;
+ }
+ fln = x * xm / eps;
+ xm = xmin - x;
+ if (xm > 7.0 && fln < 15.0) {
+ break;
+ }
+ }
+ xdmy = x;
+ xdmln = xln;
+ xinc = 0.0;
+ if (x < xmin) {
+ nx = (int) x;
+ xinc = xmin - nx;
+ xdmy = x + xinc;
+ xdmln = Math.log(xdmy);
+ }
+
+ /* generate w(n+mm-1, x) by the asymptotic expansion */
+
+ t = fn * xdmln;
+ t1 = xdmln + xdmln;
+ t2 = t + xdmln;
+ tk = Math.max(Math.abs(t), fmax2(Math.abs(t1), Math.abs(t2)));
+ if (tk <= elim) { /* for all but large x */
+ return l10(t, tk, xdmy, xdmln, x, nn, nx, wdtol, fn, trm, trmr, xinc, mm, kode, ans);
+ }
+ }
+ // nz not used
+// mVal.nz++; /* underflow */
+ mm--;
+// ans[mm] = 0.;
+ assert mm == 0;
+ ans = 0.;
+ if (mm == 0) {
+ return ans;
+ }
+ } /* end{for()} */
+ nn = (int) fln + 1;
+ np = n + 1;
+ t1 = (n + 1) * xln;
+ t = Math.exp(-t1);
+ s = t;
+ den = x;
+ for (int i = 1; i <= nn; i++) {
+ den += 1.;
+ trm[i] = Math.pow(den, -np);
+ s += trm[i];
+ }
+// ans[0] = s;
+ ans = s;
+ if (n == 0 && kode == 2) {
+// ans[0] = s + xln;
+ ans = s + xln;
+ }
+
+ if (mm != 1) { /* generate higher derivatives, j > n */
+ assert false;
+// tol = wdtol / 5.0;
+// for(j = 1; j < mm; j++) {
+// t /= x;
+// s = t;
+// tols = t * tol;
+// den = x;
+// for(i=1; i <= nn; i++) {
+// den += 1.;
+// trm[i] /= den;
+// s += trm[i];
+// if (trm[i] < tols) {
+// break;
+// }
+// }
+// ans[j] = s;
+// }
+ }
+ return ans;
+
+ }
+
+ private static double l10(double oldT, double oldTk, double xdmy, double xdmln, double x, double nn, double oldNx, double wdtol, double oldFn, double[] trm, double[] trmr, double xinc,
+ double mm, int kode, double ansOld) {
+ double t = oldT;
+ double tk = oldTk;
+ double nx = oldNx;
+ double fn = oldFn;
+ double ans = ansOld;
+
+ double tss = Math.exp(-t);
+ double tt = 0.5 / xdmy;
+ double t1 = tt;
+ double tst = wdtol * tt;
+ if (nn != 0) {
+ t1 = tt + 1.0 / fn;
+ }
+ double rxsq = 1.0 / (xdmy * xdmy);
+ double ta = 0.5 * rxsq;
+ t = (fn + 1) * ta;
+ double s = t * bvalues[2];
+ if (Math.abs(s) >= tst) {
+ tk = 2.0;
+ for (int k = 4; k <= 22; k++) {
+ t = t * ((tk + fn + 1) / (tk + 1.0)) * ((tk + fn) / (tk + 2.0)) * rxsq;
+ trm[k] = t * bvalues[k - 1];
+ if (Math.abs(trm[k]) < tst) {
+ break;
+ }
+ s += trm[k];
+ tk += 2.;
+ }
+ }
+ s = (s + t1) * tss;
+ if (xinc != 0.0) {
+
+ /* backward recur from xdmy to x */
+
+ nx = (int) xinc;
+ double np = nn + 1;
+ if (nx > n_max) {
+ // nz not used
+// mVal.nz = 0;
+ // non-zero ierr always results in generating a NaN
+// mVal.ierr = 3;
+ return Double.NaN;
+ } else {
+ if (nn == 0) {
+ return l20(xdmln, xdmy, x, s, nx, kode, ans);
+ }
+ double xm = xinc - 1.0;
+ double fx = x + xm;
+
+ /* this loop should not be changed. fx is accurate when x is small */
+ for (int i = 1; i <= nx; i++) {
+ trmr[i] = Math.pow(fx, -np);
+ s += trmr[i];
+ xm -= 1.;
+ fx = x + xm;
+ }
+ }
+ }
+// ans[mm-1] = s;
+ assert (mm - 1) == 0;
+ ans = s;
+ if (fn == 0) {
+ return l30(xdmln, xdmy, x, s, kode, ans);
+ }
+
+ /* generate lower derivatives, j < n+mm-1 */
+
+ for (int j = 2; j <= mm; j++) {
+ fn--;
+ tss *= xdmy;
+ t1 = tt;
+ if (fn != 0) {
+ t1 = tt + 1.0 / fn;
+ }
+ t = (fn + 1) * ta;
+ s = t * bvalues[2];
+ if (Math.abs(s) >= tst) {
+ tk = 4 + fn;
+ for (int k = 4; k <= 22; k++) {
+ trm[k] = trm[k] * (fn + 1) / tk;
+ if (Math.abs(trm[k]) < tst) {
+ break;
+ }
+ s += trm[k];
+ tk += 2.;
+ }
+ }
+ s = (s + t1) * tss;
+ if (xinc != 0.0) {
+ if (fn == 0) {
+ return l20(xdmln, xdmy, x, s, nx, kode, ans);
+ }
+ double xm = xinc - 1.0;
+ double fx = x + xm;
+ for (int i = 1; i <= nx; i++) {
+ trmr[i] = trmr[i] * fx;
+ s += trmr[i];
+ xm -= 1.;
+ fx = x + xm;
+ }
+ }
+// ans[mm - j] = s;
+ assert (mm - j) == 0;
+ ans = s;
+ if (fn == 0) {
+ return l30(xdmln, xdmy, x, s, kode, ans);
+ }
+ }
+ return ans;
+
+ }
+
+ private static double l20(double xdmln, double xdmy, double x, double oldS, double nx, int kode, double ans) {
+ double s = oldS;
+ for (int i = 1; i <= nx; i++) {
+ s += 1. / (x + (nx - i)); /* avoid disastrous cancellation, PR#13714 */
+ }
+
+ return l30(xdmln, xdmy, x, s, kode, ans);
+ }
+
+ private static double l30(double xdmln, double xdmy, double x, double s, int kode, double ansOld) {
+ double ans = ansOld;
+ if (kode != 2) { /* always */
+// ans[0] = s - xdmln;
+ ans = s - xdmln;
+ } else if (xdmy != x) {
+ double xq;
+ xq = xdmy / x;
+// ans[0] = s - log(xq);
+ ans = s - Math.log(xq);
+ }
+ return ans;
+ }
+ }
+
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cor.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cor.java
deleted file mode 100644
index 6689765b1e80c267c06ee2b2316f58fd4a9343dc..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cor.java
+++ /dev/null
@@ -1,62 +0,0 @@
-/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.base;
-
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.runtime.*;
-import com.oracle.truffle.r.runtime.data.*;
-
-@RBuiltin(name = "cor", kind = SUBSTITUTE, parameterNames = {"x", "y", "use", "method"})
-public abstract class Cor extends Covcor {
-
- @Override
- public RNode[] getParameterValues() {
- // x, y = NULL, use = "everything", method = c("pearson", "kendall", "spearman")
- return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(RNull.instance), ConstantNode.create("everything"),
- ConstantNode.create(RDataFactory.createStringVector(new String[]{"pearson", "kendall", "spearman"}, true))};
- }
-
- @Specialization
- protected RDoubleVector dimWithDimensions(RDoubleVector vector1, RDoubleVector vector2, @SuppressWarnings("unused") String use, @SuppressWarnings("unused") RStringVector method) {
- controlVisibility();
- return corcov(vector1, vector2, false, true);
- }
-
- @Specialization
- @SuppressWarnings("unused")
- protected RDoubleVector dimWithDimensions(RDoubleVector vector1, RMissing vector2, String use, RStringVector method) {
- controlVisibility();
- return corcov(vector1, null, false, true);
- }
-
- @Specialization
- @SuppressWarnings("unused")
- protected RDoubleVector dimWithDimensions(RDoubleVector vector1, RNull vector2, String use, RStringVector method) {
- controlVisibility();
- return corcov(vector1, null, false, true);
- }
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cov.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cov.java
deleted file mode 100644
index 697b904270a019503535851ef0921e9bf1ddf424..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Cov.java
+++ /dev/null
@@ -1,56 +0,0 @@
-/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.base;
-
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.runtime.*;
-import com.oracle.truffle.r.runtime.data.*;
-
-@RBuiltin(name = "cov", kind = SUBSTITUTE, parameterNames = {"x", "y", "use", "method"})
-public abstract class Cov extends Covcor {
-
- @Override
- public RNode[] getParameterValues() {
- // x, y = NULL, use = "everything", method = c("pearson", "kendall", "spearman")
- // TODO Is there a constant for "everyting"?
- return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(RNull.instance), ConstantNode.create("everything"),
- ConstantNode.create(RDataFactory.createStringVector(new String[]{"pearson", "kendall", "spearman"}, true))};
- }
-
- @Specialization
- protected RDoubleVector dimWithDimensions(RDoubleVector vector1, RDoubleVector vector2) {
- controlVisibility();
- return corcov(vector1, vector2, false, false);
- }
-
- @Specialization
- @SuppressWarnings("unused")
- protected RDoubleVector dimWithDimensions(RDoubleVector vector1, RMissing vector2) {
- controlVisibility();
- return corcov(vector1, null, false, false);
- }
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DynLoadFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DynLoadFunctions.java
index 85fe72a7c1f141c08161df01a0ae8c9ae9bdc747..fd7e2ade7dd73b5ff71e35b9fe696ed7ff9a4613 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DynLoadFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DynLoadFunctions.java
@@ -120,7 +120,7 @@ public class DynLoadFunctions {
@TruffleBoundary
protected byte isLoaded(String symbol, String packageName, String type) {
controlVisibility();
- boolean found = DLL.findSymbolInfo(symbol, packageName) != null;
+ boolean found = DLL.findRegisteredSymbolinInDLL(symbol, packageName) != null;
return RRuntime.asLogical(found);
}
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsVariables.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/FastR.java
similarity index 57%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsVariables.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/FastR.java
index bd245b9076987237a1447ba64a19040ae6a88a9e..4608a666ad5d032215f8d4b2571e0b8a718ab12e 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsVariables.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/FastR.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -20,30 +20,25 @@
* or visit www.oracle.com if you need additional information or have any
* questions.
*/
-package com.oracle.truffle.r.nodes.builtin.stats;
+package com.oracle.truffle.r.nodes.builtin.base;
-import com.oracle.truffle.r.nodes.builtin.base.*;
+import com.oracle.truffle.api.dsl.*;
+import com.oracle.truffle.r.nodes.builtin.*;
+import com.oracle.truffle.r.nodes.builtin.fastr.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
-import com.oracle.truffle.r.runtime.env.*;
+import com.oracle.truffle.r.runtime.data.model.*;
-public class StatsVariables implements RPackageVariables.Handler {
- // @formatter:off
- private static final String[] C_NAMES = new String[] {
- "fft"
- };
- // @formatter: on
-
- public StatsVariables() {
- RPackageVariables.registerHandler("stats", this);
- }
-
- @Override
- public void preInitialize(REnvironment statsEnv) {
- REnvironment statsNamespaceEnv = ((REnvironment.Package) statsEnv).getNamespace();
- for (String f : C_NAMES) {
- statsNamespaceEnv.safePut("C_" + f, RDataFactory.createList(new String[]{f}, BaseVariables.NAME));
- }
+/**
+ * This is a FastR-specific primitive that supports the extensions in the {@code fastr} package.
+ */
+@RBuiltin(name = ".FastR", kind = RBuiltinKind.PRIMITIVE, parameterNames = {".NAME", "..."})
+public abstract class FastR extends RBuiltinNode {
+ @Specialization
+ protected Object doFastR(RAbstractStringVector name, RArgsValuesAndNames args) {
+ controlVisibility();
+ Object[] argValues = args.getValues();
+ return FastRFunctionEntry.invoke(name.getDataAt(0), argValues, this);
}
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/ForeignFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/ForeignFunctions.java
index b9b65cfc00ef8120e068a606b30f169d82ab08ba..ff45bb0e0237769868f9b7cafab690ade0ecb63c 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/ForeignFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/ForeignFunctions.java
@@ -33,6 +33,7 @@ import com.oracle.truffle.r.nodes.*;
import com.oracle.truffle.r.nodes.access.*;
import com.oracle.truffle.r.nodes.builtin.*;
import com.oracle.truffle.r.nodes.builtin.methods.*;
+import com.oracle.truffle.r.nodes.builtin.stats.*;
import com.oracle.truffle.r.nodes.builtin.utils.*;
import com.oracle.truffle.r.nodes.unary.*;
import com.oracle.truffle.r.runtime.*;
@@ -304,55 +305,27 @@ public class ForeignFunctions {
* default packages.
*/
@RBuiltin(name = ".Call", kind = RBuiltinKind.PRIMITIVE, parameterNames = {".NAME", "...", "PACKAGE"})
- public abstract static class DotCall extends RBuiltinNode {
+ public abstract static class DotCall extends CastAdapter {
private final BranchProfile errorProfile = BranchProfile.create();
private final ConditionProfile zVecLgt1 = ConditionProfile.createBinaryProfile();
private final ConditionProfile noDims = ConditionProfile.createBinaryProfile();
- @Child private CastComplexNode castComplex;
- @Child private CastLogicalNode castLogical;
- @Child private CastToVectorNode castVector;
-
@Override
public RNode[] getParameterValues() {
return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(EMPTY_OBJECT_ARRAY), ConstantNode.create(RMissing.instance)};
}
- private Object castComplex(VirtualFrame frame, Object operand) {
- if (castComplex == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- castComplex = insert(CastComplexNodeGen.create(null, true, true, false));
- }
- return castComplex.executeCast(frame, operand);
- }
-
- private Object castLogical(VirtualFrame frame, Object operand) {
- if (castLogical == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- castLogical = insert(CastLogicalNodeGen.create(null, true, false, false));
- }
- return castLogical.executeCast(frame, operand);
- }
-
- private RAbstractVector castVector(VirtualFrame frame, Object value) {
- if (castVector == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- castVector = insert(CastToVectorNodeGen.create(null, false, false, false, false));
- }
- return (RAbstractVector) castVector.executeObject(frame, value);
- }
-
// TODO: handle more argument types (this is sufficient to run the b25 benchmarks)
@SuppressWarnings("unused")
@Specialization(guards = "fft")
protected RComplexVector callFFT(VirtualFrame frame, RList f, RArgsValuesAndNames args, RMissing packageName) {
controlVisibility();
Object[] argValues = args.getValues();
- RComplexVector zVec = (RComplexVector) castComplex(frame, castVector(frame, argValues[0]));
+ RComplexVector zVec = castComplexVector(frame, castVector(frame, argValues[0]));
double[] z = zVec.getDataTemp();
- RLogicalVector inverse = (RLogicalVector) castLogical(frame, castVector(frame, argValues[1]));
- int inv = RRuntime.isNA(inverse.getDataAt(0)) || inverse.getDataAt(0) == RRuntime.LOGICAL_FALSE ? -2 : 2;
+ byte inverse = castLogical(frame, castVector(frame, argValues[1]));
+ int inv = RRuntime.isNA(inverse) || inverse == RRuntime.LOGICAL_FALSE ? -2 : 2;
int retCode = 7;
if (zVecLgt1.profile(zVec.getLength() > 1)) {
int[] maxf = new int[1];
@@ -560,6 +533,68 @@ public class ForeignFunctions {
return matchName(f, "cairoProps");
}
+ @Specialization(guards = "isCor")
+ protected Object doCor(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ return doCovCor(frame, false, args);
+ }
+
+ public boolean isCor(RList f) {
+ return matchName(f, "cor");
+ }
+
+ @Specialization(guards = "isCov")
+ protected Object doCov(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ return doCovCor(frame, true, args);
+ }
+
+ public boolean isCov(RList f) {
+ return matchName(f, "cov");
+ }
+
+ private Object doCovCor(VirtualFrame frame, boolean isCov, RArgsValuesAndNames args) {
+ controlVisibility();
+ Object[] argValues = args.getValues();
+ if (argValues[0] == RNull.instance) {
+ throw RError.error(getEncapsulatingSourceSection(), RError.Message.IS_NULL, "x");
+ }
+ // TODO error checks/coercions
+ RDoubleVector x = (RDoubleVector) argValues[0];
+ RDoubleVector y = argValues[1] == RNull.instance ? null : (RDoubleVector) argValues[1];
+ int method = ((RIntVector) argValues[2]).getDataAt(0);
+ if (method != 4) {
+ throw RError.nyi(getEncapsulatingSourceSection(), " method ");
+ }
+ boolean iskendall = RRuntime.fromLogical(castLogical(frame, castVector(frame, argValues[3])));
+ return Covcor.getInstance().corcov(x, y, method, iskendall, !isCov, getEncapsulatingSourceSection());
+
+ }
+
+ @Specialization(guards = "isSplineCoef")
+ protected RList splineCoef(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ Object[] argValues = args.getValues();
+ int method = castInt(frame, castVector(frame, argValues[0]));
+ RDoubleVector x = (RDoubleVector) castVector(frame, argValues[1]);
+ RDoubleVector y = (RDoubleVector) castVector(frame, argValues[2]);
+ return SplineFunctions.splineCoef(method, x, y);
+ }
+
+ public boolean isSplineCoef(RList f) {
+ return matchName(f, "SplineCoef");
+ }
+
+ @Specialization(guards = "isSplineEval")
+ protected RDoubleVector splineEval(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ Object[] argValues = args.getValues();
+ RDoubleVector xout = (RDoubleVector) castVector(frame, argValues[0]);
+ // This is called with the result of SplineCoef, so it is surely an RList
+ RList z = (RList) argValues[1];
+ return SplineFunctions.splineEval(xout, z);
+ }
+
+ public boolean isSplineEval(RList f) {
+ return matchName(f, "SplineEval");
+ }
+
}
/**
@@ -594,25 +629,57 @@ public class ForeignFunctions {
}
}
+ /**
+ * Casts for use on value elements of {@link RArgsValuesAndNames}. Since the starting value
+ * could a scalar, first use {@link #castVector}.
+ */
private abstract static class CastAdapter extends RBuiltinNode {
@Child private CastLogicalNode castLogical;
@Child private CastIntegerNode castInt;
+ @Child private CastDoubleNode castDouble;
+ @Child private CastComplexNode castComplex;
+ @Child private CastToVectorNode castVector;
- protected byte castLogical(VirtualFrame frame, Object operand) {
+ protected byte castLogical(VirtualFrame frame, RAbstractVector operand) {
if (castLogical == null) {
CompilerDirectives.transferToInterpreterAndInvalidate();
castLogical = insert(CastLogicalNodeGen.create(null, false, false, false));
}
- return (byte) castLogical.executeCast(frame, operand);
+ return ((RLogicalVector) castLogical.executeCast(frame, operand)).getDataAt(0);
}
- protected int castInt(VirtualFrame frame, Object operand) {
+ protected int castInt(VirtualFrame frame, RAbstractVector operand) {
if (castInt == null) {
CompilerDirectives.transferToInterpreterAndInvalidate();
castInt = insert(CastIntegerNodeGen.create(null, false, false, false));
}
- return (int) castInt.executeCast(frame, operand);
+ return ((RIntVector) castInt.executeCast(frame, operand)).getDataAt(0);
+ }
+
+ protected RDoubleVector castDouble(VirtualFrame frame, RAbstractVector operand) {
+ if (castDouble == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ castDouble = insert(CastDoubleNodeGen.create(null, false, false, false));
+ }
+ return (RDoubleVector) castDouble.executeCast(frame, operand);
+ }
+
+ protected RComplexVector castComplexVector(VirtualFrame frame, Object operand) {
+ if (castComplex == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ castComplex = insert(CastComplexNodeGen.create(null, true, true, false));
+ }
+ return (RComplexVector) castComplex.executeCast(frame, operand);
}
+
+ protected RAbstractVector castVector(VirtualFrame frame, Object value) {
+ if (castVector == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ castVector = insert(CastToVectorNodeGen.create(null, false, false, false, false));
+ }
+ return (RAbstractVector) castVector.executeObject(frame, value);
+ }
+
}
@RBuiltin(name = ".External", kind = RBuiltinKind.PRIMITIVE, parameterNames = {".NAME", "...", "PACKAGE"})
@@ -630,8 +697,8 @@ public class ForeignFunctions {
Object sepArg = argValues[1];
char sepChar;
Object quoteArg = argValues[2];
- int nskip = castInt(frame, argValues[3]);
- byte blskip = castLogical(frame, argValues[4]);
+ int nskip = castInt(frame, castVector(frame, argValues[3]));
+ byte blskip = castLogical(frame, castVector(frame, argValues[4]));
String commentCharArg = isString(argValues[5]);
char comChar;
if (!(commentCharArg != null && commentCharArg.length() == 1)) {
@@ -690,7 +757,7 @@ public class ForeignFunctions {
controlVisibility();
Object[] argValues = args.getValues();
RConnection conn = (RConnection) argValues[0];
- int nlines = castInt(frame, argValues[1]);
+ int nlines = castInt(frame, castVector(frame, argValues[1]));
try {
return RDataFactory.createStringVector(conn.readLines(nlines), RDataFactory.COMPLETE_VECTOR);
} catch (IOException ex) {
@@ -702,22 +769,63 @@ public class ForeignFunctions {
public boolean isReadTableHead(RList f) {
return matchName(f, "readtablehead");
}
+
+ @Specialization(guards = "isRnorm")
+ protected Object doRnorm(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ controlVisibility();
+ Object[] argValues = args.getValues();
+ int n = castInt(frame, castVector(frame, argValues[0]));
+ // TODO full error checks
+ double mean = (double) argValues[1];
+ double standardd = (double) argValues[2];
+ return Random2.rnorm(n, mean, standardd);
+ }
+
+ public boolean isRnorm(RList f) {
+ return matchName(f, "rnorm");
+ }
+
+ @Specialization(guards = "isRunif")
+ protected Object doRunif(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ controlVisibility();
+ Object[] argValues = args.getValues();
+ // TODO full error checks
+ int n = castInt(frame, castVector(frame, argValues[0]));
+ double min = (castDouble(frame, castVector(frame, argValues[1]))).getDataAt(0);
+ double max = (castDouble(frame, castVector(frame, argValues[2]))).getDataAt(0);
+ return Runif.runif(n, min, max);
+ }
+
+ public boolean isRunif(RList f) {
+ return matchName(f, "runif");
+ }
+
+ @Specialization(guards = "isQgamma")
+ protected RDoubleVector doQgamma(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args, @SuppressWarnings("unused") RMissing packageName) {
+ controlVisibility();
+ Object[] argValues = args.getValues();
+ RDoubleVector p = (RDoubleVector) castVector(frame, argValues[0]);
+ RDoubleVector shape = (RDoubleVector) castVector(frame, argValues[1]);
+ RDoubleVector scale = (RDoubleVector) castVector(frame, argValues[2]);
+ if (shape.getLength() == 0 || scale.getLength() == 0) {
+ return RDataFactory.createEmptyDoubleVector();
+ }
+ byte lowerTail = castLogical(frame, castVector(frame, argValues[3]));
+ byte logP = castLogical(frame, castVector(frame, argValues[4]));
+ return GammaFunctions.Qgamma.getInstance().qgamma(p, shape, scale, lowerTail, logP);
+ }
+
+ public boolean isQgamma(RList f) {
+ return matchName(f, "qgamma");
+ }
+
}
@RBuiltin(name = ".External2", kind = RBuiltinKind.PRIMITIVE, parameterNames = {".NAME", "..."})
public abstract static class DotExternal2 extends CastAdapter {
- @Child private CastToVectorNode castVector;
private final BranchProfile errorProfile = BranchProfile.create();
- private RAbstractVector castVector(VirtualFrame frame, Object value) {
- if (castVector == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- castVector = insert(CastToVectorNodeGen.create(null, false, false, false, false));
- }
- return (RAbstractVector) castVector.executeObject(frame, value);
- }
-
// Transcribed from GnuR, library/utils/src/io.c
@Specialization(guards = "isWriteTable")
protected Object doWriteTable(VirtualFrame frame, @SuppressWarnings("unused") RList f, RArgsValuesAndNames args) {
@@ -733,15 +841,15 @@ public class ForeignFunctions {
}
// TODO check connection writeable
- int nr = castInt(frame, argValues[2]);
- int nc = castInt(frame, argValues[3]);
+ int nr = castInt(frame, castVector(frame, argValues[2]));
+ int nc = castInt(frame, castVector(frame, argValues[3]));
Object rnamesArg = argValues[4];
Object sepArg = argValues[5];
Object eolArg = argValues[6];
Object naArg = argValues[7];
Object decArg = argValues[8];
Object quoteArg = argValues[9];
- byte qmethod = castLogical(frame, argValues[10]);
+ byte qmethod = castLogical(frame, castVector(frame, argValues[10]));
String csep;
String ceol;
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/HiddenInternalFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/HiddenInternalFunctions.java
index ad8ea811f92c104dab1c367487dc2a6c20743302..d4d4406ff6a44ba8a5ff023f46724924e622df13 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/HiddenInternalFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/HiddenInternalFunctions.java
@@ -34,7 +34,6 @@ import com.oracle.truffle.r.runtime.data.model.*;
import com.oracle.truffle.r.runtime.env.*;
import com.oracle.truffle.r.runtime.env.REnvironment.*;
import com.oracle.truffle.r.runtime.ffi.*;
-import com.oracle.truffle.r.runtime.ffi.DLL.RegisteredNativeType;
/**
* Private, undocumented, {@code .Internal} and {@code .Primitive} functions transcribed from GnuR.
@@ -149,11 +148,16 @@ public class HiddenInternalFunctions {
*/
@Specialization
public Object lazyLoadDBFetch(VirtualFrame frame, RIntVector key, RStringVector datafile, RIntVector compressed, RFunction envhook) {
- return lazyLoadDBFetchInternal(frame.materialize(), key, datafile, compressed, envhook);
+ return lazyLoadDBFetchInternal(frame.materialize(), key, datafile, compressed.getDataAt(0), envhook);
+ }
+
+ @Specialization
+ public Object lazyLoadDBFetch(VirtualFrame frame, RIntVector key, RStringVector datafile, RDoubleVector compressed, RFunction envhook) {
+ return lazyLoadDBFetchInternal(frame.materialize(), key, datafile, (int) compressed.getDataAt(0), envhook);
}
@TruffleBoundary
- public Object lazyLoadDBFetchInternal(MaterializedFrame frame, RIntVector key, RStringVector datafile, RIntVector compressed, RFunction envhook) {
+ public Object lazyLoadDBFetchInternal(MaterializedFrame frame, RIntVector key, RStringVector datafile, int compression, RFunction envhook) {
String dbPath = datafile.getDataAt(0);
byte[] dbData = dbCache.get(dbPath);
if (dbData == null) {
@@ -175,7 +179,6 @@ public class HiddenInternalFunctions {
dataLengthBuf.position(0);
byte[] data = new byte[length - 4];
System.arraycopy(dbData, offset + 4, data, 0, data.length);
- int compression = compressed.getDataAt(0);
if (compression == 1) {
int outlen = dataLengthBuf.getInt();
byte[] udata = new byte[outlen];
@@ -219,7 +222,7 @@ public class HiddenInternalFunctions {
private static final RStringVector NATIVE_ROUTINE_LIST = RDataFactory.createStringVectorFromScalar("NativeRoutineList");
@Specialization
- protected RList getRegisteredRoutines(RNull info) {
+ protected RList getRegisteredRoutines(@SuppressWarnings("unused") RNull info) {
throw RError.error(getEncapsulatingSourceSection(), RError.Message.NULL_DLLINFO);
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Options.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Options.java
index 1da9946af18a8f64e7687e0f9cdd87b3e4e6ae58..760af05f488de6c7b3b1328d664fb44e6a996b10 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Options.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Options.java
@@ -42,6 +42,7 @@ public abstract class Options extends RBuiltinNode {
private final ConditionProfile argNameNull = ConditionProfile.createBinaryProfile();
+ @TruffleBoundary
@Specialization
protected RList options(@SuppressWarnings("unused") RMissing x) {
controlVisibility();
@@ -87,7 +88,7 @@ public abstract class Options extends RBuiltinNode {
if (nn instanceof RStringVector) {
thisListnames = (RStringVector) nn;
} else {
- assert false;
+ throw RInternalError.shouldNotReachHere();
}
Object[] listData = new Object[list.getLength()];
String[] listNames = new String[listData.length];
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/cut.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/cut.R
new file mode 100644
index 0000000000000000000000000000000000000000..261bf89d4d51ce80b319859a3f92140b6318149a
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/cut.R
@@ -0,0 +1,72 @@
+# File src/library/base/R/cut.R
+# Part of the R package, http://www.R-project.org
+#
+# Copyright (C) 1995-2014 The R Core Team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# A copy of the GNU General Public License is available at
+# http://www.r-project.org/Licenses/
+
+cut <- function(x, ...) UseMethod("cut")
+
+cut.default <-
+ function (x, breaks, labels = NULL, include.lowest = FALSE,
+ right = TRUE, dig.lab = 3L, ordered_result = FALSE, ...)
+{
+ if (!is.numeric(x)) stop("'x' must be numeric")
+ if (length(breaks) == 1L) {
+ if (is.na(breaks) || breaks < 2L)
+ stop("invalid number of intervals")
+ nb <- as.integer(breaks + 1) # one more than #{intervals}
+ dx <- diff(rx <- range(x, na.rm = TRUE))
+ if(dx == 0) {
+ dx <- abs(rx[1L])
+ breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000,
+ length.out = nb)
+ } else {
+ breaks <- seq.int(rx[1L], rx[2L], length.out = nb)
+ breaks[c(1L, nb)] <- c(rx[1L] - dx/1000, rx[2L] + dx/1000)
+ }
+ } else nb <- length(breaks <- sort.int(as.double(breaks)))
+ if (anyDuplicated(breaks)) stop("'breaks' are not unique")
+ codes.only <- FALSE
+ if (is.null(labels)) {#- try to construct nice ones ..
+ for(dig in dig.lab:max(12L, dig.lab)) {
+ ## 0+ avoids printing signed zeros as "-0"
+ ch.br <- formatC(0+breaks, digits = dig, width = 1L)
+ if(ok <- all(ch.br[-1L] != ch.br[-nb])) break
+ }
+ labels <-
+ if(ok) paste0(if(right)"(" else "[",
+ ch.br[-nb], ",", ch.br[-1L],
+ if(right)"]" else ")")
+ else paste("Range", seq_len(nb - 1L), sep="_")
+ if (ok && include.lowest) {
+ if (right)
+ substr(labels[1L], 1L, 1L) <- "[" # was "("
+ else
+ substring(labels[nb-1L],
+ nchar(labels[nb-1L], "c")) <- "]" # was ")"
+ }
+ } else if (is.logical(labels) && !labels)
+ codes.only <- TRUE
+ else if (length(labels) != nb - 1L)
+ stop("lengths of 'breaks' and 'labels' differ")
+ code <- .bincode(x, breaks, right, include.lowest)
+ if(codes.only) code
+ else factor(code, seq_along(labels), labels, ordered = ordered_result)
+}
+
+## called from image.default and for use in packages.
+.bincode <- function(x, breaks, right = TRUE, include.lowest = FALSE)
+ .Internal(bincode(x, breaks, right, include.lowest))
+
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/merge.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/merge.R
new file mode 100644
index 0000000000000000000000000000000000000000..208fdf51bb70a7eb59ed32709dd939ebe2085039
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/R/merge.R
@@ -0,0 +1,178 @@
+# File src/library/base/R/merge.R
+# Part of the R package, http://www.R-project.org
+#
+# Copyright (C) 1995-2012 The R Core Team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# A copy of the GNU General Public License is available at
+# http://www.r-project.org/Licenses/
+
+merge <- function(x, y, ...) UseMethod("merge")
+
+merge.default <- function(x, y, ...)
+ merge(as.data.frame(x), as.data.frame(y), ...)
+
+merge.data.frame <-
+ function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
+ all = FALSE, all.x = all, all.y = all,
+ sort = TRUE, suffixes = c(".x",".y"), incomparables = NULL,
+ ...)
+{
+ fix.by <- function(by, df)
+ {
+ ## fix up 'by' to be a valid set of cols by number: 0 is row.names
+ if(is.null(by)) by <- numeric()
+ by <- as.vector(by)
+ nc <- ncol(df)
+ if(is.character(by)) {
+ poss <- c("row.names", names(df))
+ # names(df) are not necessarily unique, so check for multiple matches.
+ if(any(bad <- !charmatch(by, poss, 0L)))
+ stop(ngettext(sum(bad),
+ "'by' must specify a uniquely valid column",
+ "'by' must specify uniquely valid columns"),
+ domain = NA)
+ by <- match(by, poss) - 1L
+ } else if(is.numeric(by)) {
+ if(any(by < 0L) || any(by > nc))
+ stop("'by' must match numbers of columns")
+ } else if(is.logical(by)) {
+ if(length(by) != nc) stop("'by' must match number of columns")
+ by <- seq_along(by)[by]
+ } else stop("'by' must specify one or more columns as numbers, names or logical")
+ if(any(bad <- is.na(by)))
+ stop(ngettext(sum(bad),
+ "'by' must specify a uniquely valid column",
+ "'by' must specify uniquely valid columns"),
+ domain = NA)
+ unique(by)
+ }
+
+ nx <- nrow(x <- as.data.frame(x)); ny <- nrow(y <- as.data.frame(y))
+ if (nx >= 2^31 || ny >= 2^31) stop("long vectors are not supported")
+ by.x <- fix.by(by.x, x)
+ by.y <- fix.by(by.y, y)
+ if((l.b <- length(by.x)) != length(by.y))
+ stop("'by.x' and 'by.y' specify different numbers of columns")
+ if(l.b == 0L) {
+ ## return the cartesian product of x and y, fixing up common names
+ nm <- nm.x <- names(x)
+ nm.y <- names(y)
+ has.common.nms <- any(cnm <- nm.x %in% nm.y)
+ if(has.common.nms) {
+ names(x)[cnm] <- paste0(nm.x[cnm], suffixes[1L])
+ cnm <- nm.y %in% nm
+ names(y)[cnm] <- paste0(nm.y[cnm], suffixes[2L])
+ }
+ if (nx == 0L || ny == 0L) {
+ res <- cbind(x[FALSE, ], y[FALSE, ])
+ } else {
+ ij <- expand.grid(seq_len(nx), seq_len(ny))
+ res <- cbind(x[ij[, 1L], , drop = FALSE], y[ij[, 2L], , drop = FALSE])
+ }
+ }
+ else {
+ if(any(by.x == 0L)) {
+ x <- cbind(Row.names = I(row.names(x)), x)
+ by.x <- by.x + 1L
+ }
+ if(any(by.y == 0L)) {
+ y <- cbind(Row.names = I(row.names(y)), y)
+ by.y <- by.y + 1L
+ }
+ row.names(x) <- NULL
+ row.names(y) <- NULL
+ ## create keys from 'by' columns:
+ if(l.b == 1L) { # (be faster)
+ bx <- x[, by.x]; if(is.factor(bx)) bx <- as.character(bx)
+ by <- y[, by.y]; if(is.factor(by)) by <- as.character(by)
+ } else {
+ if (!is.null(incomparables))
+ stop("'incomparables' is supported only for merging on a single column")
+ ## Do these together for consistency in as.character.
+ ## Use same set of names.
+ bx <- x[, by.x, drop=FALSE]; by <- y[, by.y, drop=FALSE]
+ names(bx) <- names(by) <- paste0("V", seq_len(ncol(bx)))
+ bz <- do.call("paste", c(rbind(bx, by), sep = "\r"))
+ bx <- bz[seq_len(nx)]
+ by <- bz[nx + seq_len(ny)]
+ }
+ comm <- match(bx, by, 0L)
+ bxy <- bx[comm > 0L] # the keys which are in both
+ xinds <- match(bx, bxy, 0L, incomparables)
+ yinds <- match(by, bxy, 0L, incomparables)
+ if(nx > 0L && ny > 0L)
+ m <- .Internal(merge(xinds, yinds, all.x, all.y))
+ else
+ m <- list(xi = integer(), yi = integer(),
+ x.alone = seq_len(nx), y.alone = seq_len(ny))
+ nm <- nm.x <- names(x)[-by.x]
+ nm.by <- names(x)[by.x]
+ nm.y <- names(y)[-by.y]
+ ncx <- ncol(x)
+ if(all.x) all.x <- (nxx <- length(m$x.alone)) > 0L
+ if(all.y) all.y <- (nyy <- length(m$y.alone)) > 0L
+ lxy <- length(m$xi) # == length(m$yi)
+ ## x = [ by | x ] :
+ has.common.nms <- any(cnm <- nm.x %in% nm.y)
+ if(has.common.nms && nzchar(suffixes[1L]))
+ nm.x[cnm] <- paste0(nm.x[cnm], suffixes[1L])
+ x <- x[c(m$xi, if(all.x) m$x.alone),
+ c(by.x, seq_len(ncx)[-by.x]), drop=FALSE]
+ names(x) <- c(nm.by, nm.x)
+ if(all.y) { ## add the 'y.alone' rows to x[]
+ ## need to have factor levels extended as well -> using [cr]bind
+ ya <- y[m$y.alone, by.y, drop = FALSE]
+ names(ya) <- nm.by
+ ## this used to use a logical matrix, but that was not good
+ ## enough as x could be zero-row.
+ ## workaround possibly duplicated names: PR#15618
+ xa <- x[rep.int(NA_integer_, nyy), nm.x, drop=FALSE ]
+ names(xa) <- nm.x
+ x <- rbind(x, cbind(ya, xa))
+ }
+ ## y (w/o 'by'):
+ if(has.common.nms && nzchar(suffixes[2L])) {
+ cnm <- nm.y %in% nm
+ nm.y[cnm] <- paste0(nm.y[cnm], suffixes[2L])
+ }
+ y <- y[c(m$yi, if(all.x) rep.int(1L, nxx), if(all.y) m$y.alone),
+ -by.y, drop = FALSE]
+ if(all.x) {
+ zap <- (lxy+1L):(lxy+nxx)
+ for(i in seq_along(y)) {
+ ## do it this way to invoke methods for e.g. factor
+ if(is.matrix(y[[1]])) y[[1]][zap, ] <- NA
+ else is.na(y[[i]]) <- zap
+ }
+ }
+
+ if(has.common.nms) names(y) <- nm.y
+ nm <- c(names(x), names(y))
+ if(any(d <- duplicated(nm)))
+ if(sum(d) > 1L)
+ warning("column names ",
+ paste(sQuote(nm[d]), collapse = ", "),
+ " are duplicated in the result", domain = NA)
+ else
+ warning("column name ", sQuote(nm[d]),
+ " is duplicated in the result", domain = NA)
+ res <- cbind(x, y)
+
+ if (sort)
+ res <- res[if(all.x || all.y) ## does NOT work
+ do.call("order", x[, seq_len(l.b), drop = FALSE])
+ else sort.list(bx[m$xi]),, drop = FALSE]
+ }
+ attr(res, "row.names") <- .set_row_names(nrow(res))
+ res
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCallCounting.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCallCounting.java
index c3b9e29f7f2af883c903c1c59ab463f44c0f6046..32db769e9b4aaf2774126c7e430a5670ceea1566 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCallCounting.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCallCounting.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,24 +22,14 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import com.oracle.truffle.api.dsl.Specialization;
import com.oracle.truffle.api.instrument.Probe;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.ConstantNode;
-import com.oracle.truffle.r.nodes.builtin.RBuiltinNode;
-import com.oracle.truffle.r.nodes.builtin.RInvisibleBuiltinNode;
import com.oracle.truffle.r.nodes.function.FunctionDefinitionNode;
import com.oracle.truffle.r.nodes.function.FunctionUID;
import com.oracle.truffle.r.nodes.instrument.REntryCounters;
import com.oracle.truffle.r.nodes.instrument.RInstrument;
import com.oracle.truffle.r.nodes.instrument.RSyntaxTag;
-import com.oracle.truffle.r.runtime.*;
-
-import static com.oracle.truffle.r.runtime.RBuiltinKind.PRIMITIVE;
-
import com.oracle.truffle.r.runtime.RError;
import com.oracle.truffle.r.runtime.data.RFunction;
-import com.oracle.truffle.r.runtime.data.RMissing;
import com.oracle.truffle.r.runtime.data.RNull;
/**
@@ -48,67 +38,33 @@ import com.oracle.truffle.r.runtime.data.RNull;
*/
public class FastRCallCounting {
- @RBuiltin(name = "fastr.createcc", kind = PRIMITIVE, parameterNames = {"func"})
- public abstract static class FastRCreateCallCounter extends RInvisibleBuiltinNode {
-
- @Specialization
- protected RNull createCallCounter(@SuppressWarnings("unused") RMissing function) {
- controlVisibility();
- throw RError.error(RError.Message.ARGUMENTS_PASSED_0_1);
- }
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance)};
- }
-
- @Specialization
- protected Object createCallCounter(RFunction function) {
- controlVisibility();
- if (!function.isBuiltin()) {
- FunctionDefinitionNode fdn = (FunctionDefinitionNode) function.getRootNode();
- FunctionUID uuid = fdn.getUID();
- if (REntryCounters.findCounter(uuid) == null) {
- Probe probe = RInstrument.findSingleProbe(uuid, RSyntaxTag.FUNCTION_BODY);
- if (probe == null) {
- throw RError.error(getEncapsulatingSourceSection(), RError.Message.GENERIC, "failed to apply counter");
- } else {
- REntryCounters.Function counter = new REntryCounters.Function(uuid);
- probe.attach(counter.instrument);
- }
+ public static Object createCallCounter(RFunction function) {
+ if (!function.isBuiltin()) {
+ FunctionDefinitionNode fdn = (FunctionDefinitionNode) function.getRootNode();
+ FunctionUID uuid = fdn.getUID();
+ if (REntryCounters.findCounter(uuid) == null) {
+ Probe probe = RInstrument.findSingleProbe(uuid, RSyntaxTag.FUNCTION_BODY);
+ if (probe == null) {
+ throw RError.error(null, RError.Message.GENERIC, "failed to apply counter, instrumention disabled?");
+ } else {
+ REntryCounters.Function counter = new REntryCounters.Function(uuid);
+ probe.attach(counter.instrument);
}
}
- return RNull.instance;
}
+ return RNull.instance;
}
- @RBuiltin(name = "fastr.getcc", kind = PRIMITIVE, parameterNames = {"func"})
- public abstract static class FastRGetCallCount extends RBuiltinNode {
-
- @Specialization
- protected RNull getCallCount(@SuppressWarnings("unused") RMissing function) {
- controlVisibility();
- throw RError.error(RError.Message.ARGUMENTS_PASSED_0_1);
- }
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance)};
- }
-
- @Specialization
- protected Object getCallCount(RFunction function) {
- controlVisibility();
- if (!function.isBuiltin()) {
- FunctionDefinitionNode fdn = (FunctionDefinitionNode) function.getRootNode();
- REntryCounters.Function counter = (REntryCounters.Function) REntryCounters.findCounter(fdn.getUID());
- if (counter == null) {
- throw RError.error(getEncapsulatingSourceSection(), RError.Message.GENERIC, "no associated counter");
- }
- return counter.getEnterCount();
+ public static Object getCallCount(RFunction function) {
+ if (!function.isBuiltin()) {
+ FunctionDefinitionNode fdn = (FunctionDefinitionNode) function.getRootNode();
+ REntryCounters.Function counter = (REntryCounters.Function) REntryCounters.findCounter(fdn.getUID());
+ if (counter == null) {
+ throw RError.error(null, RError.Message.GENERIC, "no associated counter");
}
- return RNull.instance;
+ return counter.getEnterCount();
}
+ return RNull.instance;
}
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompileBuiltin.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompile.java
similarity index 73%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompileBuiltin.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompile.java
index 1ded99f99b642fffe30783bc790119978e39e05f..a3e04b21c90503aaee44a3ec228b329f0ca2d88d 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompileBuiltin.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRCompile.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,26 +22,13 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
import java.lang.reflect.*;
import com.oracle.truffle.api.*;
-import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
-@RBuiltin(name = "fastr.compile", kind = PRIMITIVE, parameterNames = {"func", "background"})
-public abstract class FastRCompileBuiltin extends RBuiltinNode {
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{null, ConstantNode.create(RRuntime.LOGICAL_TRUE)};
- }
+public class FastRCompile {
private static final class Compiler {
private final Class<?> optimizedCallTarget;
@@ -79,27 +66,17 @@ public abstract class FastRCompileBuiltin extends RBuiltinNode {
private static final Compiler compiler = Compiler.getCompiler();
- @Specialization
- @TruffleBoundary
- protected byte compileFunction(RFunction function, byte background) {
- controlVisibility();
+ public static byte compileFunction(RFunction function, byte background) {
if (compiler != null) {
try {
if (compiler.compile(function.getTarget(), background == RRuntime.LOGICAL_TRUE)) {
return RRuntime.LOGICAL_TRUE;
}
} catch (InvocationTargetException | IllegalAccessException e) {
- throw RError.error(getEncapsulatingSourceSection(), RError.Message.GENERIC, e.toString());
+ throw RError.error(null, RError.Message.GENERIC, e.toString());
}
}
return RRuntime.LOGICAL_FALSE;
}
- @SuppressWarnings("unused")
- @Fallback
- protected byte compileFunction(Object function, Object background) {
- controlVisibility();
- CompilerDirectives.transferToInterpreter();
- throw RError.error(getEncapsulatingSourceSection(), RError.Message.INVALID_UNNAMED_ARGUMENTS);
- }
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpBuiltin.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpTrees.java
similarity index 90%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpBuiltin.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpTrees.java
index 26f79c6f7a71d6b27a0407d44be467a8542e6fe5..97522c48c3fe736dd9e89727f1ccea86a77b4c72 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpBuiltin.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRDumpTrees.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,7 +22,6 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import com.oracle.truffle.api.dsl.Specialization;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.api.nodes.NodeUtil;
import com.oracle.truffle.api.nodes.NodeUtil.NodeClass;
@@ -30,39 +29,24 @@ import com.oracle.truffle.api.nodes.NodeUtil.NodeField;
import com.oracle.truffle.api.nodes.NodeUtil.NodeFieldKind;
import com.oracle.truffle.api.nodes.RootNode;
import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.ConstantNode;
-import com.oracle.truffle.r.nodes.builtin.RBuiltinComment;
-import com.oracle.truffle.r.nodes.builtin.RInvisibleBuiltinNode;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.RFunction;
-import com.oracle.truffle.r.runtime.data.RMissing;
import com.oracle.truffle.r.runtime.data.RNull;
import java.io.*;
import static com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.PRIMITIVE;
/**
* Dump Truffle trees to a listening IGV instance, if any. If igvDump == FALSE, dumps tree to
* .dot-file in the cwd
*/
-@RBuiltin(name = "fastr.dumptrees", kind = PRIMITIVE, parameterNames = {"func", "igvDump", "verbose"})
-@RBuiltinComment("Dumps Truffle trees to IGV if an IGV instance running. If igvDump == FALSE, tree is dumped into .dot file in the cwd.")
-public abstract class FastRDumpBuiltin extends RInvisibleBuiltinNode {
+public class FastRDumpTrees {
private static final int FUNCTION_LENGTH_LIMIT = 40;
private static final String DOT_TREE_FILE_NAME = "tree.dot";
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(RRuntime.LOGICAL_FALSE), ConstantNode.create(RRuntime.LOGICAL_FALSE)};
- }
-
- @Specialization
- @TruffleBoundary
- protected Object dump(RFunction function, byte igvDump, byte verbose) {
- controlVisibility();
+ public static Object dump(RFunction function, byte igvDump, byte verbose) {
RootNode root = function.getTarget().getRootNode();
if (igvDump == RRuntime.LOGICAL_FALSE) {
@@ -80,7 +64,7 @@ public abstract class FastRDumpBuiltin extends RInvisibleBuiltinNode {
/*
* Output of dot-files representing the tree
*/
- public String writeDotTreeToFile(Node root, boolean verbose) {
+ public static String writeDotTreeToFile(Node root, boolean verbose) {
File dotFile = new File(DOT_TREE_FILE_NAME);
try {
// Open output file
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRFunctionEntry.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRFunctionEntry.java
new file mode 100644
index 0000000000000000000000000000000000000000..fe4671a8b653b76acc6a73d52c8c2a9377ae7995
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRFunctionEntry.java
@@ -0,0 +1,92 @@
+/*
+ * Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
+ * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+ *
+ * This code is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License version 2 only, as
+ * published by the Free Software Foundation.
+ *
+ * This code is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * version 2 for more details (a copy is included in the LICENSE file that
+ * accompanied this code).
+ *
+ * You should have received a copy of the GNU General Public License version
+ * 2 along with this work; if not, write to the Free Software Foundation,
+ * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+ *
+ * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+ * or visit www.oracle.com if you need additional information or have any
+ * questions.
+ */
+package com.oracle.truffle.r.nodes.builtin.fastr;
+
+import com.oracle.truffle.r.nodes.builtin.*;
+import com.oracle.truffle.r.runtime.*;
+import com.oracle.truffle.r.runtime.data.*;
+
+/**
+ * The entry point to all the {@code fastr.xxx} functions called by the {@code .FastR} primitive.
+ */
+public class FastRFunctionEntry {
+ public static Object invoke(String name, Object[] argValues, RBuiltinNode fastRNode) {
+ Object arg0 = argValues[0];
+ if (name.equals("typeof")) {
+ return arg0.getClass().getSimpleName();
+ } else if (name.equals("stacktrace")) {
+ fastRNode.forceVisibility(false);
+ return FastRStackTrace.printStackTrace(checkLogical(argValues[0], fastRNode));
+ }
+ // The remainder all take a func argument
+ RFunction func = checkFunction(arg0, fastRNode);
+ switch (name) {
+ case "createcc":
+ fastRNode.forceVisibility(false);
+ return FastRCallCounting.createCallCounter(func);
+ case "getcc":
+ return FastRCallCounting.getCallCount(func);
+
+ case "compile":
+ return FastRCompile.compileFunction(func, checkLogical(argValues[1], fastRNode));
+
+ case "dumptrees":
+ fastRNode.forceVisibility(false);
+ return FastRDumpTrees.dump(func, checkLogical(argValues[1], fastRNode), checkLogical(argValues[2], fastRNode));
+
+ case "source":
+ return FastRSource.debugSource(func);
+
+ case "tree":
+ return FastRTree.printTree(func, checkLogical(argValues[1], fastRNode));
+
+ case "syntaxtree":
+ fastRNode.forceVisibility(false);
+ return FastRSyntaxTree.printTree(func);
+
+ case "seqlengths":
+ return FastRSyntaxTree.printTree(func);
+
+ default:
+ throw RInternalError.shouldNotReachHere();
+ }
+
+ }
+
+ private static RFunction checkFunction(Object arg, RBuiltinNode fastRNode) throws RError {
+ if (arg instanceof RFunction) {
+ return (RFunction) arg;
+ } else {
+ throw RError.error(fastRNode.getEncapsulatingSourceSection(), RError.Message.TYPE_EXPECTED, "function");
+ }
+ }
+
+ private static byte checkLogical(Object arg, RBuiltinNode fastRNode) throws RError {
+ if (arg instanceof Byte) {
+ return (byte) arg;
+ } else {
+ throw RError.error(fastRNode.getEncapsulatingSourceSection(), RError.Message.TYPE_EXPECTED, "logical");
+ }
+ }
+
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRInfoBuiltin.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRInfoBuiltin.java
deleted file mode 100644
index 174bff667134be859045cda1362fc9ad89d1f00f..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRInfoBuiltin.java
+++ /dev/null
@@ -1,71 +0,0 @@
-/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.fastr;
-
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import java.util.*;
-
-import com.oracle.truffle.api.CompilerDirectives.*;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
-
-@RBuiltin(name = "fastr.info", kind = PRIMITIVE, parameterNames = {})
-@RBuiltinComment("Prints this message.")
-public abstract class FastRInfoBuiltin extends RBuiltinNode {
-
- @TruffleBoundary
- @Specialization
- protected Object printTree() {
- controlVisibility();
- RContext.getInstance();
- StringBuilder b = new StringBuilder();
- for (RBuiltinPackage pack : RBuiltinPackages.getPackages().values()) {
- b.append(createPackageString(pack));
- }
- return b.toString();
- }
-
- @TruffleBoundary
- private static String createPackageString(RBuiltinPackage pack) {
- Map<String, RBuiltinFactory> builtins = pack.getBuiltins();
- StringBuilder msg = new StringBuilder();
- msg.append(String.format("%s functions: %n", pack.getName()));
- for (String name : builtins.keySet()) {
- RBuiltinFactory factory = builtins.get(name);
- RBuiltinComment commentAnnotation = factory.getFactory().getNodeClass().getAnnotation(RBuiltinComment.class);
- String comment = null;
- if (commentAnnotation != null) {
- comment = commentAnnotation.value();
- }
-
- if (comment == null || comment.isEmpty()) {
- comment = "";
- }
-
- msg.append(String.format(" - %s : %s%n", name, comment));
- }
- return msg.toString();
- }
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRRunDump.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRRunDump.java
deleted file mode 100644
index 6f0038dd5a5f8072e30d65abbac9be96706fee53..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRRunDump.java
+++ /dev/null
@@ -1,80 +0,0 @@
-/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.fastr;
-
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.graal.debug.*;
-import com.oracle.graal.debug.Debug.Scope;
-import com.oracle.truffle.api.*;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.api.frame.*;
-import com.oracle.truffle.api.nodes.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
-import com.oracle.truffle.r.runtime.data.*;
-
-/**
- * Run a FastR function, and dump its AST to IGV before and after running. If no function is passed,
- * this builtin does not do anything.
- */
-@RBuiltin(name = "fastr.rundump", parameterNames = {"func"}, kind = PRIMITIVE)
-public abstract class FastRRunDump extends RInvisibleBuiltinNode {
-
- // TODO Make this more versatile by allowing actual function calls with arguments to be
- // observed. This requires ... to work properly.
-
- @Child private IndirectCallNode call = Truffle.getRuntime().createIndirectCallNode();
-
- private final GraphPrintVisitor graphPrinter = new GraphPrintVisitor();
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RNull.instance)};
- }
-
- @Specialization
- protected Object runDump(RNull function) {
- return function;
- }
-
- @Specialization
- protected Object runDump(VirtualFrame frame, RFunction function) {
- controlVisibility();
- Object r = RNull.instance;
- graphPrinter.beginGroup(RRuntime.toString(function));
- try (Scope s = Debug.scope("FastR")) {
- graphPrinter.beginGraph("before").visit(function.getTarget().getRootNode());
- r = call.call(frame, function.getTarget(), RArguments.create(function, call.getSourceSection(), RArguments.getDepth(frame) + 1));
- graphPrinter.beginGraph("after").visit(function.getTarget().getRootNode());
- } catch (Throwable t) {
- Debug.handle(t);
- } finally {
- graphPrinter.printToNetwork(true);
- }
- return r;
- }
-
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSource.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSource.java
index d8c6a8a06d7d6e69f2d312253fb24c3c433f04ce..e25852e43d237c02fdb95a9f5713c04e2e8375b3 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSource.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSource.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,27 +22,16 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
import java.util.*;
import com.oracle.truffle.api.*;
-import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import com.oracle.truffle.api.dsl.*;
import com.oracle.truffle.api.impl.*;
import com.oracle.truffle.api.nodes.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
-@RBuiltin(name = "fastr.source", kind = PRIMITIVE, parameterNames = {"func"})
-@RBuiltinComment("Returns the source code associated with a function, and for all of its nodes.")
-public abstract class FastRSource extends RBuiltinNode {
+public class FastRSource {
- @TruffleBoundary
- @Specialization
- protected String debugSource(RFunction f) {
- controlVisibility();
+ public static String debugSource(RFunction f) {
CallTarget ct = f.getTarget();
if (!(ct instanceof DefaultCallTarget)) {
return "<no default call target>";
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRStackTrace.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRStackTrace.java
index 69126de9fe0fd40b3a4f188de0e2386d5c76acb6..74eb6714de91b59f21b9ac02859190bb6c82f9f7 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRStackTrace.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRStackTrace.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,28 +22,11 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
import com.oracle.truffle.r.runtime.*;
-@RBuiltin(name = "fastr.stacktrace", kind = PRIMITIVE, parameterNames = {"print.frame.contents"})
-@RBuiltinComment("Prints current stack trace. If 'print.frame.contents' is TRUE, each frame's content is printed, too.")
-public abstract class FastRStackTrace extends RInvisibleBuiltinNode {
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RRuntime.LOGICAL_TRUE)};
- }
+public class FastRStackTrace {
- @Specialization
- @TruffleBoundary
- protected Object printStackTrace(byte printFrameContents) {
- controlVisibility();
+ public static Object printStackTrace(byte printFrameContents) {
boolean printFrameSlots = printFrameContents == RRuntime.LOGICAL_TRUE;
RContext.getInstance().getConsoleHandler().print(Utils.createStackTrace(printFrameSlots));
return RRuntime.NULL;
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSyntaxTree.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSyntaxTree.java
index 82f0a6f35d7e62823598e06b01e25834529e3752..cb59fde31449c8153da4ee4c8684e1eb7b37828d 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSyntaxTree.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRSyntaxTree.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,28 +22,13 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.dsl.*;
import com.oracle.truffle.api.nodes.*;
import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
import com.oracle.truffle.r.nodes.function.*;
-import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
-@RBuiltin(name = "fastr.syntaxtree", kind = PRIMITIVE, parameterNames = {"func"})
-@RBuiltinComment("Prints the syntactic view of the Truffle tree of a function.")
-public abstract class FastRSyntaxTree extends RInvisibleBuiltinNode {
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance)};
- }
-
- @Specialization
- protected Object printTree(RFunction function) {
- controlVisibility();
+public class FastRSyntaxTree {
+ public static Object printTree(RFunction function) {
Node root = function.getTarget().getRootNode();
RSyntaxNode.accept(root, 0, new RSyntaxNodeVisitor() {
@@ -62,16 +47,4 @@ public abstract class FastRSyntaxTree extends RInvisibleBuiltinNode {
return RNull.instance;
}
- @Specialization
- protected RNull printTree(@SuppressWarnings("unused") RMissing function) {
- controlVisibility();
- throw RError.error(RError.Message.ARGUMENTS_PASSED_0_1);
- }
-
- @Fallback
- protected RNull printTree(@SuppressWarnings("unused") Object function) {
- controlVisibility();
- throw RError.error(RError.Message.INVALID_ARGUMENT, "func");
- }
-
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRPackage.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTree.java
similarity index 66%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRPackage.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTree.java
index d926961b9d3bbaa07aee4c52ba4aedcc6ca532fb..b74b054dd29e188f82b2c68e5411c6a92702685a 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRPackage.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTree.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,17 +22,19 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import com.oracle.truffle.r.nodes.builtin.*;
+import com.oracle.truffle.api.nodes.*;
+import com.oracle.truffle.r.runtime.*;
+import com.oracle.truffle.r.runtime.data.*;
-public class FastRPackage extends RBuiltinPackage {
+public class FastRTree {
- public FastRPackage() {
- loadBuiltins();
- }
-
- @Override
- public String getName() {
- return "fastr";
+ public static Object printTree(RFunction function, byte verbose) {
+ RootNode root = function.getTarget().getRootNode();
+ if (verbose == RRuntime.LOGICAL_TRUE) {
+ return NodeUtil.printTreeToString(root);
+ } else {
+ return NodeUtil.printCompactTreeToString(root);
+ }
}
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeBuiltin.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeBuiltin.java
deleted file mode 100644
index fefb29e9c5576cf97c1c5c91f3e2dd4b7e4a414b..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeBuiltin.java
+++ /dev/null
@@ -1,64 +0,0 @@
-/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.fastr;
-
-import static com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.CompilerDirectives;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.api.nodes.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
-import com.oracle.truffle.r.runtime.data.*;
-
-@RBuiltin(name = "fastr.tree", kind = PRIMITIVE, parameterNames = {"func", "verbose"})
-@RBuiltinComment("Prints the Truffle tree of a function. Use debug.tree(a, TRUE) for more detailed output.")
-public abstract class FastRTreeBuiltin extends RBuiltinNode {
-
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(RRuntime.LOGICAL_FALSE)};
- }
-
- @Specialization
- @TruffleBoundary
- protected Object printTree(RFunction function, byte verbose) {
- controlVisibility();
- RootNode root = function.getTarget().getRootNode();
- if (verbose == RRuntime.LOGICAL_TRUE) {
- return NodeUtil.printTreeToString(root);
- } else {
- return NodeUtil.printCompactTreeToString(root);
- }
- }
-
- @Fallback
- protected RNull printTree(Object function, @SuppressWarnings("unused") Object verbose) {
- controlVisibility();
- CompilerDirectives.transferToInterpreter();
- throw RError.error(RError.Message.INVALID_VALUE, RRuntime.toString(function));
- }
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeStats.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeStats.java
index 1e8187121247321128bc6443000cf90c3ffaca9e..4a6b12eb54ebc03cf3158d475672c61e7cc5ea28 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeStats.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTreeStats.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,57 +22,26 @@
*/
package com.oracle.truffle.r.nodes.builtin.fastr;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.dsl.*;
import com.oracle.truffle.api.nodes.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
import com.oracle.truffle.r.nodes.control.SequenceNode;
-import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
import java.util.List;
public class FastRTreeStats {
- @RBuiltin(name = "fastr.seqlengths", kind = PRIMITIVE, parameterNames = {"func"})
- @RBuiltinComment("Show SequenceNode lengths")
- public abstract static class FastRSeqLengths extends RInvisibleBuiltinNode {
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{ConstantNode.create(RMissing.instance)};
- }
-
- @Specialization
- protected Object seqLengths(RFunction function) {
- controlVisibility();
- List<SequenceNode> list = NodeUtil.findAllNodeInstances(function.getTarget().getRootNode(), SequenceNode.class);
- int[] counts = new int[11];
- for (SequenceNode s : list) {
- int l = s.getSequence().length;
- if (l > counts.length - 1) {
- counts[counts.length - 1]++;
- } else {
- counts[l]++;
- }
+ public static Object seqLengths(RFunction function) {
+ List<SequenceNode> list = NodeUtil.findAllNodeInstances(function.getTarget().getRootNode(), SequenceNode.class);
+ int[] counts = new int[11];
+ for (SequenceNode s : list) {
+ int l = s.getSequence().length;
+ if (l > counts.length - 1) {
+ counts[counts.length - 1]++;
+ } else {
+ counts[l]++;
}
- return RDataFactory.createIntVector(counts, RDataFactory.COMPLETE_VECTOR);
- }
-
- @Specialization
- protected RNull printTree(@SuppressWarnings("unused") RMissing function) {
- controlVisibility();
- throw RError.error(RError.Message.ARGUMENTS_PASSED_0_1);
- }
-
- @Fallback
- protected RNull printTree(@SuppressWarnings("unused") Object function) {
- controlVisibility();
- throw RError.error(RError.Message.INVALID_ARGUMENT, "func");
}
-
+ return RDataFactory.createIntVector(counts, RDataFactory.COMPLETE_VECTOR);
}
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTypeOfBuiltin.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTypeOfBuiltin.java
deleted file mode 100644
index 9b1a602ebbb66eb5fba24b1dcbf560c4bb65d2c9..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/fastr/FastRTypeOfBuiltin.java
+++ /dev/null
@@ -1,44 +0,0 @@
-/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.nodes.builtin.fastr;
-
-import com.oracle.truffle.api.dsl.Specialization;
-import com.oracle.truffle.r.nodes.builtin.RBuiltinComment;
-import com.oracle.truffle.r.nodes.builtin.RBuiltinNode;
-import com.oracle.truffle.r.runtime.RBuiltin;
-
-import static com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.PRIMITIVE;
-
-@RBuiltin(name = "fastr.typeof", kind = PRIMITIVE, parameterNames = {"x"})
-@RBuiltinComment("Returns a simple string representation of the internal runtime type of a value.")
-public abstract class FastRTypeOfBuiltin extends RBuiltinNode {
-
- @Specialization
- @TruffleBoundary
- protected String type(Object value) {
- controlVisibility();
- return value.getClass().getSimpleName();
- }
-
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/graphics/GraphicsCCalls.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/graphics/GraphicsCCalls.java
new file mode 100644
index 0000000000000000000000000000000000000000..2530324360f73b592b2ff122682e48466a7c0f48
--- /dev/null
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/graphics/GraphicsCCalls.java
@@ -0,0 +1,5 @@
+package com.oracle.truffle.r.nodes.builtin.graphics;
+
+public class GraphicsCCalls {
+
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RClassUtils.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RClassUtils.R
deleted file mode 100644
index b2b084876466e3bdd0a3df6a220088acc9211047..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RClassUtils.R
+++ /dev/null
@@ -1,2465 +0,0 @@
-# File src/library/methods/R/RClassUtils.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2013 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-## http://www.r-project.org/Licenses/
-#
-#testVirtual <-
-# ## Test for a Virtual Class.
-# ## Figures out, as well as possible, whether the class with these properties,
-# ## extension, and prototype is a virtual class.
-# ## Can be forced to be virtual by extending "VIRTUAL". Otherwise, a class is
-# ## virtual only if it has no slots, extends no non-virtual classes, and has a
-# ## NULL Prototype
-# function(properties, extends, prototype, where)
-#{
-# if(length(extends)) {
-# en <- names(extends)
-# if(!is.na(match("VIRTUAL", en)))
-# return(TRUE)
-# ## does the class extend a known non-virtual class?
-# for(what in en) {
-# enDef <- getClassDef(what, where)
-# if(!is.null(enDef) && identical(enDef@virtual, FALSE))
-# return(FALSE)
-# }
-# }
-# (length(properties) == 0L && is.null(prototype))
-#}
-#
-#makePrototypeFromClassDef <-
-# ## completes the prototype implied by
-# ## the class definition.
-# ##
-# ## The following three rules are applied in this order.
-# ##
-# ## If the class has slots, then the prototype for each
-# ## slot is used by default, but a corresponding element in the explicitly supplied
-# ## prototype, if there is one, is used instead (but it must be coercible to the
-# ## class of the slot).
-# ##
-# ## If there are no slots but a non-null prototype was specified, this is returned.
-# ##
-# ## If there is a single non-virtual superclass (a class in the extends list),
-# ## then its prototype is used.
-# ##
-# ## If all three of the above fail, the prototype is `NULL'.
-# function(slots, ClassDef, extends, where)
-#{
-# className <- ClassDef@className
-# snames <- names(slots)
-# ## try for a single superclass that is not virtual
-# supers <- names(extends)
-# virtual <- NA
-# dataPartClass <- elNamed(slots, ".Data")
-# prototype <- ClassDef@prototype
-# dataPartDone <- is.null(dataPartClass) || is(prototype, dataPartClass)# don't look for data part in supreclasses
-# ## check for a formal prototype object (TODO: sometime ensure that this happens
-# ## at setClass() time, so prototype slot in classRepresentation can have that class
-# if(!.identC(class(prototype), className) && .isPrototype(prototype)) {
-# pnames <- prototype@slots
-# prototype <- prototype@object
-# }
-# else
-# pnames <- names(attributes(prototype))
-# if(length(slots) == 0L && !is.null(prototype))
-# return(prototype)
-# for(i in seq_along(extends)) {
-# what <- el(supers, i)
-# exti <- extends[[i]]
-# if(identical(exti@simple, FALSE))
-# next ## only simple contains rel'ns give slots
-# if(identical(what, "VIRTUAL"))
-# ## the class is virtual, and the prototype usually NULL
-# virtual <- TRUE
-# else if(isClass(what, where = where)) {
-# cli <- getClass(what, where = where)
-# slotsi <- names(cli@slots)
-# pri <- cli@prototype
-# ## once in a while
-# if(is.null(prototype)) {
-# prototype <- pri
-# pnames <- names(attributes(prototype))
-# fromClass <- what
-# }
-# else if(length(slots)) {
-# for(slotName in slotsi) {
-# if(identical(slotName, ".Data")) {
-# if(!dataPartDone) {
-# prototype <- setDataPart(prototype, getDataPart(pri), FALSE)
-# dataPartDone <- TRUE
-# }
-# }
-# else if(is.na(match(slotName, pnames))) {
-# ## possible that the prototype already had this slot specified
-# ## If not, add it now.
-# attr(prototype, slotName) <- attr(pri, slotName)
-# pnames <- c(pnames, slotName)
-# }
-# }
-# }
-# else if(!dataPartDone && extends(cli, dataPartClass)) {
-# prototype <- setDataPart(prototype, pri, FALSE)
-# dataPartDone <- TRUE
-# }
-# }
-# }
-# if(length(slots) == 0L)
-# return(prototype)
-# if(is.null(prototype))
-# prototype <- defaultPrototype()
-# pnames <- names(attributes(prototype))
-# ## watch out for a prototype of this class. Not supposed to happen, but will
-# ## at least for the basic class "ts", and can lead to inf. recursion
-# pslots <-
-# if(.identC(class(prototype), className))
-# names(attributes(unclass(prototype)))
-# else if(isClass(class(prototype)))
-# names(getSlots(getClass(class(prototype))))
-# ## else NULL
-#
-# ## now check that all the directly specified slots have corresponding elements
-# ## in the prototype--the inherited slots were done in the loop over extends
-# if(!is.na(match(".Data", snames))) {
-# dataPartClass <- elNamed(slots, ".Data")
-#
-# ## check the data part
-# if(!(isVirtualClass(dataPartClass))) {
-# if(isClass(class(prototype), where = where)) {
-# prototypeClass <- getClass(class(prototype), where = where)
-# OK <- extends(prototypeClass, dataPartClass)
-# }
-# else
-# OK <- FALSE
-# if(identical(OK, FALSE))
-# stop(gettextf("in constructing the prototype for class %s: prototype has class %s, but the data part specifies class %s",
-# dQuote(className),
-# dQuote(.class1(prototype)),
-# dQuote(dataPartClass)),
-# domain = NA)
-# }
-# iData <- -match(".Data", snames)
-# snames <- snames[iData]
-# slots <- slots[iData]
-# }
-# for(j in seq_along(snames)) {
-# name <- el(snames, j)
-# i <- match(name, pnames)
-# if(is.na(i)) {
-# ## if the class of the j-th element of slots is defined and non-virtual,
-# ## generate an object from it; else insert NULL
-# slot(prototype, name, check = FALSE) <- tryNew(el(slots, j), where)
-# }
-# }
-# extra <- pnames[is.na(match(pnames, snames)) & !is.na(match(pnames, pslots))]
-# if(length(extra) && is.na(match("oldClass", supers)))
-# warning(gettextf("in constructing the prototype for class %s, slots in prototype and not in class: %s",
-# dQuote(className),
-# paste(extra, collapse=", ")),
-# domain = NA)
-# ## now check the elements of the prototype against the class definition
-# slotDefs <- getSlots(ClassDef); slotNames <- names(slotDefs)
-# pnames <- names(attributes(prototype))
-# pnames <- pnames[!is.na(match(pnames, slotNames))]
-# check <- rep.int(FALSE, length(pnames))
-# for(what in pnames) {
-# pwhat <- slot(prototype, what)
-# slotClass <- getClassDef(slotDefs[[what]], where)
-# if(is.null(slotClass) || !extends(class(pwhat), slotClass)) {
-# if(is.null(pwhat)) { # does this still apply??
-# }
-# else if(is(slotClass, "classRepresentation") &&
-# slotClass@virtual) {} # no nonvirtual prototype;e.g. S3 class
-# else
-# check[match(what, pnames)] <- TRUE
-# }
-# }
-# if(any(check))
-# stop(gettextf("in making the prototype for class %s elements of the prototype failed to match the corresponding slot class: %s",
-# dQuote(className),
-# paste(pnames[check],
-# "(class",
-# .dQ(slotDefs[match(pnames[check], slotNames)]),
-# ")",
-# collapse = ", ")),
-# domain = NA)
-# prototype
-#}
-#
-#newEmptyObject <-
-# ## Utility function to create an empty object into which slots can be
-# ## set. Currently just creates an empty list with class "NULL"
-# ##
-# ## Later version should create a special object reference that marks an
-# ## object currently with no slots and no data.
-# function()
-#{
-# value <- list()
-# value
-#}
-#
-#
-#completeClassDefinition <-
-# ## Completes the definition of Class, relative to the current environment
-# ##
-# ## The completed definition is stored in the session's class metadata,
-# ## to be retrieved the next time that getClass is called on this class,
-# ## and is returned as the value of the call.
-# function(Class, ClassDef = getClassDef(Class), where, doExtends = TRUE)
-#{
-# ClassDef <- .completeClassSlots(ClassDef, where)
-# immediate <- ClassDef@contains
-# properties <- ClassDef@slots
-# prototype <- makePrototypeFromClassDef(properties, ClassDef, immediate, where)
-# virtual <- ClassDef@virtual
-# validity <- ClassDef@validity
-# access <- ClassDef@access
-# package <- ClassDef@package
-# extends <- if(doExtends) completeExtends (ClassDef, where = where) else ClassDef@contains
-# subclasses <- if(doExtends) completeSubclasses(ClassDef, where = where) else ClassDef@subclasses
-# if(is.na(virtual))
-# ## compute it from the immediate extensions, but all the properties
-# virtual <- testVirtual(properties, immediate, prototype, where)
-# ## modify the initial class definition object, rather than creating
-# ## a new one, to allow extensions of "classRepresentation"
-# ## Done by a separate function to allow a bootstrap version.
-# ClassDef <- .mergeClassDefSlots(ClassDef,
-# slots = properties,
-# contains = extends,
-# prototype = prototype,
-# virtual = virtual,
-# subclasses = subclasses)
-# if(any(!is.na(match(names(ClassDef@subclasses), names(ClassDef@contains))))
-# && getOption("warn") > 0 ## NEEDED: a better way to turn on strict testing
-# ) {
-# bad <- names(ClassDef@subclasses)[!is.na(match(names(ClassDef@subclasses), names(ClassDef@contains)))]
-# warning(gettextf("potential cycle in class inheritance: %s has duplicates in superclasses and subclasses (%s)",
-# dQuote(Class),
-# paste(bad, collapse = ", ")),
-# domain = NA)
-# }
-# ClassDef
-#}
-#
-#.completeClassSlots <- function(ClassDef, where) {
-# properties <- ClassDef@slots
-# simpleContains <- ClassDef@contains
-# Class <- ClassDef@className
-# package <- ClassDef@package
-# ext <- getAllSuperClasses(ClassDef, TRUE)
-# ## ext has the names of all the direct and indirect superClasses but NOT those that do
-# ## an explicit coerce (we can't conclude anything about slots, etc. from them)
-# if(length(ext)) {
-# superProps <- vector("list", length(ext)+1L)
-# superProps[[1L]] <- properties
-# for(i in seq_along(ext)) {
-# eClass <- ext[[i]]
-# if(isClass(eClass, where = where))
-# superProps[[i+1]] <- getClassDef(eClass, where = where)@slots
-# }
-# properties <- unlist(superProps, recursive = FALSE)
-# ## check for conflicting slot names
-# if(anyDuplicated(allNames(properties))) {
-# duped <- duplicated(names(properties))
-##TEMPORARY -- until classes are completed in place & we have way to match non-inherited slots
-# properties <- properties[!duped]
-## dupNames <- unique(names(properties)[duped])
-## if(!is.na(match(".Data", dupNames))) {
-## dataParts <- seq_along(properties)[names(properties) == ".Data"]
-## dupNames <- dupNames[dupNames != ".Data"]
-## ## inherited data part classes are OK but should be consistent
-## dataPartClasses <- unique(as.character(properties[dataParts]))
-## if(length(dataPartClasses)>1)
-## warning("Inconsistent data part classes inherited (",
-## paste(dataPartClasses, collapse = ", "),
-## "): coercion to some may fail")
-## ## remove all but the first .Data
-## properties <- properties[-dataParts[-1L]]
-## }
-## if(length(dupNames)>0) {
-## dupClasses <- logical(length(superProps))
-## for(i in seq_along(superProps)) {
-## dupClasses[i] <- !all(is.na(match(dupNames, names(superProps[[i]]))))
-## }
-## stop(paste("Duplicate slot names: slots ",
-## paste(dupNames, collapse =", "), "; see classes ",
-## paste0(c(Class, ext)[dupClasses], collapse = ", ")))
-## }
-# }
-# }
-# ## ensure that each element of the slots is a valid class reference
-# undefClasses <- rep.int(FALSE, length(properties))
-# for(i in seq_along(properties)) {
-# cli <- properties[[i]]
-# if(is.null(packageSlot(cli))) {
-# cliDef <- getClassDef(cli, where)
-# if(is.null(cliDef))
-# undefClasses[[i]] <- TRUE
-# else
-# packageSlot(properties[[i]]) <- cliDef@package
-# }
-# else {
-# cliDef <- getClassDef(cli)
-# if(is.null(cliDef))
-# undefClasses[[i]] <- TRUE
-# }
-# }
-# if(any(undefClasses))
-# warning(gettextf("undefined slot classes in definition of %s: %s",
-# .dQ(ClassDef@className),
-# paste(names(properties)[undefClasses], "(class ",
-# .dQ(unlist(properties, recursive = FALSE)[undefClasses]),
-# ")", collapse = ", ", sep = "")),
-# call. = FALSE, domain = NA)
-# ClassDef@slots <- properties
-# ClassDef
-#}
-#
-#.uncompleteClassDefinition <- function(ClassDef, slotName) {
-# if(missing(slotName)) {
-# ClassDef <- Recall(ClassDef, "contains")
-# Recall(ClassDef, "subclasses")
-# }
-# else {
-# prev <- slot(ClassDef, slotName)
-# if(length(prev)) {
-# indir <- sapply(prev, .isIndirectExtension)
-# slot(ClassDef, slotName) <- slot(ClassDef, slotName)[!indir]
-# }
-# ClassDef
-# }
-#}
-#
-#.isIndirectExtension <- function(object) {
-# is(object, "SClassExtension") && length(object@by) > 0
-#}
-#
-#.mergeSlots <- function(classDef1, classDef2) {
-#
-#}
-#
-#.directSubClasses <- function(ClassDef) {
-# ## no checks for input here:
-# if(length(sc <- ClassDef@subclasses)) {
-# names(sc)[sapply(sc, function(cc) cc@distance == 1L)]
-# } ## else NULL
-#}
-#
-#getAllSuperClasses <-
-# ## Get the names of all the classes that this class definition extends.
-# ##
-# ## A utility function used to complete a class definition. It
-# ## returns all the superclasses reachable from this class, in
-# ## depth-first order (which is the order used for matching methods);
-# ## that is, the first direct superclass followed by all its
-# ## superclasses, then the next, etc. (The order is relevant only in
-# ## the case that some of the superclasses have multiple inheritance.)
-# ##
-# ## The list of superclasses is stored in the extends property of the
-# ## session metadata. User code should not need to call
-# ## getAllSuperClasses directly; instead, use getClass()@contains
-# ## (which will complete the definition if necessary).
-# function(ClassDef, simpleOnly = TRUE) {
-# temp <- superClassDepth(ClassDef, simpleOnly = simpleOnly)
-# unique(temp$label[sort.list(temp$depth)])
-#}
-#
-#superClassDepth <-
-# ## all the superclasses of ClassDef, along with the depth of the relation
-# ## Includes the extension definitions, but these are not currently used by
-# ## getAllSuperClasses
-# function(ClassDef, soFar = ClassDef@className, simpleOnly = TRUE)
-#{
-# ext <- ClassDef@contains
-# ## remove indirect and maybe non-simple superclasses (latter for inferring slots)
-# ok <- rep.int(TRUE, length(ext))
-# for(i in seq_along(ext)) {
-# exti <- ext[[i]]
-# if(.isIndirectExtension(exti) ||
-# (simpleOnly && ! exti @simple))
-# ok[i] <- FALSE
-# }
-# ext <- ext[ok]
-# immediate <- names(ext)
-# notSoFar <- is.na(match(immediate, soFar))
-# immediate <- immediate[notSoFar]
-# super <- list(label = immediate, depth = rep.int(1, length(immediate)),
-# ext = ext)
-# for(i in seq_along(immediate)) {
-# what <- immediate[[i]]
-# if(!is.na(match(what, soFar)))
-# ## watch out for loops (e.g., matrix/array have mutual is relationship)
-# next
-# exti <- ext[[i]]
-# soFar <- c(soFar, what)
-# if(!is(exti, "SClassExtension"))
-# stop(gettextf("in definition of class %s, information for superclass %s is of class %s (expected \"SClassExtension\")",
-# dQuote(ClassDef@className),
-# dQuote(what),
-# dQuote(class(exti))),
-# domain = NA)
-# superClass <- getClassDef(exti@superClass, package = exti@package)
-# if(is.null(superClass)) {
-# warning(gettextf("class %s extends an undefined class, %s",
-# dQuote(ClassDef@className),
-# dQuote(what)),
-# domain = NA)
-# next
-# }
-# more <- Recall(superClass, soFar)
-# whatMore <- more$label
-# if(!all(is.na(match(whatMore, soFar)))) {
-# ## elminate classes reachable by more than one path
-# ## (This is allowed in the model, however)
-# ok <- is.na(match(whatMore, soFar))
-# more$depth <- more$depth[ok]
-# more$label <- more$label[ok]
-# more$ext <- more$ext[ok]
-# whatMore <- whatMore[ok]
-# }
-# if(length(whatMore)) {
-# soFar <- c(soFar, whatMore)
-# super$depth <- c(super$depth, 1+more$depth)
-# super$label <- c(super$label, more$label)
-# super$ext <- c(super$ext, more$ext)
-# }
-# }
-# super
-#}
-#
-#selectSuperClasses <-
-# function(Class, dropVirtual = FALSE, namesOnly = TRUE,
-# directOnly = TRUE, simpleOnly = directOnly,
-# where = topenv(parent.frame()))
-#{
-# ext <- if(isClassDef(Class))
-# Class@contains
-# else if(isClass(Class, where = where))
-# getClass(Class, where = where)@contains
-# else stop("'Class' must be a valid class definition or class")
-#
-# .selectSuperClasses(ext, dropVirtual = dropVirtual, namesOnly = namesOnly,
-# directOnly = directOnly, simpleOnly = simpleOnly)
-#}
-#
-#.selectSuperClasses <- function(ext, dropVirtual = FALSE, namesOnly = TRUE,
-# directOnly = TRUE, simpleOnly = directOnly)
-#{
-# ## No argument checking here
-# addCond <- function(xpr, prev)
-# if(length(prev)) substitute(P && N, list(P = prev, N = xpr)) else xpr
-# C <- if(dropVirtual) {
-# ## NB the default 'where' in getClass() may depend on specific superClass:
-# isVirtualExt <- function(x) getClass(x@superClass)@virtual
-# quote(!isVirtualExt(exti))
-# } else expression()
-# if(directOnly) C <- addCond(quote(length(exti@by) == 0), C)
-# if(simpleOnly) C <- addCond(quote(exti@simple), C)
-# if(length(C)) {
-# F <- function(exti){}; body(F) <- C
-# ext <- ext[unlist(lapply(ext, F), use.names=FALSE)]
-# }
-# if(namesOnly) names(ext) else ext
-#}
-#
-#inheritedSlotNames <- function(Class, where = topenv(parent.frame()))
-#{
-# ext <- if(isClassDef(Class))
-# Class@contains
-# else if(isClass(Class, where = where))
-# getClass(Class, where = where)@contains
-# supcl <- .selectSuperClasses(ext) ## maybe simpleOnly = FALSE or use as argument?
-# unique(unlist(lapply(lapply(supcl, getClassDef), slotNames), use.names=FALSE))
-# ## or just the non-simplified part (*with* names):
-# ## lapply(sapply(supcl, getClassDef, simplify=FALSE), slotNames)
-#}
-#
-#
-#isVirtualClass <-
-# ## Is the named class a virtual class? A class is virtual if explicitly declared to
-# ## be, and also if the class is not formally defined.
-# function(Class, where = topenv(parent.frame())) {
-# if(isClassDef(Class))
-# Class@virtual
-# else if(isClass(Class, where = where))
-# getClass(Class, where = where)@virtual
-# else
-# TRUE
-#}
-#
-#
-#assignClassDef <-
-# ## assign the definition of the class to the specially named object
-# function(Class, def, where = .GlobalEnv, force = FALSE) {
-# if(!is(def,"classRepresentation"))
-# stop(gettextf("trying to assign an object of class %s as the definition of class %s: must supply a \"classRepresentation\" object",
-# dQuote(class(def)),
-# dQuote(Class)),
-# domain = NA)
-# clName <- def@className; attributes(clName) <- NULL
-# if(!.identC(Class, clName))
-# stop(gettextf("assigning as %s a class representation with internal name %s",
-# dQuote(Class),
-# dQuote(def@className)),
-# domain = NA)
-# where <- as.environment(where)
-# mname <- classMetaName(Class)
-# if(exists(mname, envir = where, inherits = FALSE) && bindingIsLocked(mname, where)) {
-# if(force)
-# .assignOverBinding(mname, def, where, FALSE)
-# ## called this way, e.g., from setIs()
-# ## This is old and bad. Given that the cached version of the class
-# ## will have all the updated info about a class, we should leave
-# ## the locked version alone. But probably too late to fix without
-# ## a lot of flack. (JMC, 2013/10)
-# else
-# stop(gettextf("class %s has a locked definition in package %s",
-# dQuote(Class), sQuote(getPackageName(where))))
-# }
-# else
-# assign(mname, def, where)
-# if(cacheOnAssign(where)) # will be FALSE for sourceEnvironment's
-# .cacheClass(clName, def, is(def, "ClassUnionRepresentation"), where)
-#}
-#
-#
-#.InitClassDefinition <- function(where) {
-# defSlots <- list(slots = "list", contains = "list", virtual = "logical",
-# prototype = "ANY", validity = "OptionalFunction", access = "list",
-# ## the above are to conform to the API; now some extensions
-# className = "character", package = "character",
-# subclasses = "list", versionKey = "externalptr", ## or "integer"??
-# sealed = "logical")
-# ## the prototype of a new class def'n: virtual class with NULL prototype
-# protoSlots <- list(slots=list(), contains=list(), virtual=NA,
-# prototype = NULL, validity = NULL,
-# access = list(), className = character(), package = character(),
-# subclasses = list(), versionKey = .newExternalptr(),
-# sealed = FALSE)
-# proto <- defaultPrototype()
-# pnames <- names(protoSlots)
-# for(i in seq_along(protoSlots))
-# slot(proto, pnames[[i]], FALSE) <- protoSlots[[i]]
-# classRepClass <- .classNameFromMethods("classRepresentation")
-# class(proto) <- classRepClass
-# object <- defaultPrototype()
-# class(object) <- classRepClass
-# slot(object, "slots", FALSE) <- defSlots
-# slot(object, "className", FALSE) <- classRepClass
-# slot(object, "virtual", FALSE) <- FALSE
-# slot(object, "prototype", FALSE) <- proto
-# for(what in c("contains", "validity", "access", "hasValidity", "subclasses",
-# "versionKey"))
-# slot(object, what, FALSE) <- elNamed(protoSlots, what)
-# slot(object, "sealed", FALSE) <- TRUE
-# slot(object, "package", FALSE) <- getPackageName(where)
-# ## assignClassDef("classRepresentation", object, where)
-# assign(classMetaName("classRepresentation"), object, where)
-# ## the list of needed generics, initially empty (see .InitStructureMethods)
-# assign(".NeedPrimitiveMethods", list(), where)
-#}
-#
-#.classNameFromMethods <- function(what) {
-# packageSlot(what) <- "methods"
-# what
-#}
-#
-#.initClassSupport <- function(where) {
-# setClass("classPrototypeDef", representation(object = "ANY", slots = "character", dataPart = "logical"),
-# sealed = TRUE, where = where)
-# setClass(".Other", representation(label = "character"),
-# sealed = TRUE, where = where) # nonvirtual, nobody's subclass, see testInheritedMethods
-# ## a class and a method for reporting method selection ambiguities
-# setClass("MethodSelectionReport",
-# representation(generic = "character", allSelections = "character", target = "character", selected = "character", candidates = "list", note = "character"),
-# sealed = TRUE, where = where)
-# setClass("classGeneratorFunction",
-# representation(className = "character", package = "character"),
-# contains = "function")
-#}
-#
-#
-#newBasic <-
-# ## the implementation of the function `new' for basic classes.
-# ##
-# ## See `new' for the interpretation of the arguments.
-# function(Class, ...) {
-# msg <- NULL
-# value <- switch(Class,
-# "NULL" = return(NULL), ## can't set attr's of NULL in R
-# "logical" =,
-# "numeric" =,
-# "character" =,
-# "complex" =,
-# "integer" =,
-# "raw" =,
-# "list" = as.vector(c(...), Class),
-# "expression" = eval(substitute(expression(...))),
-# "externalptr" = {
-# if(nargs() > 1)
-# stop("'externalptr' objects cannot be initialized from new()")
-# .newExternalptr()
-# },
-# "single" = as.single(c(...)),
-# ## note on array, matrix: not possible to be compatible with
-# ## S-Plus on array, unless R allows 0-length .Dim attribute
-# "array" = if(!missing(...)) array(...) else structure(numeric(), .Dim =0L),
-# "matrix" = if (!missing(...)) matrix(...) else matrix(0, 0L, 0L),
-## "ts" = ts(...),
-## break dependence on package stats
-# "ts" = if(!missing(...)) stats::ts(...) else
-# structure(NA, .Tsp = c(1, 1, 1), class = "ts"),
-#
-# ## otherwise:
-# {
-# args <- list(...)
-# if(length(args) == 1L && is(args[[1L]], Class)) {
-# value <- as(args[[1L]], Class)
-# }
-# else if(is.na(match(Class, .BasicClasses)))
-# msg <- paste("Calling new() on an undefined and non-basic class (\"",
-# Class, "\")", sep="")
-# else
-# msg <-
-# gettextf("initializing objects from class %s with these arguments is not supported",
-# dQuote(Class))
-# }
-# )
-# if(is.null(msg))
-# value
-# else
-# stop(msg, domain = NA)
-#}
-#
-#
-### this non-exported function turns on or off
-### the use of the S4 type as class prototype
-#.useS4Prototype <- function(on = TRUE, where = .methodsNamespace) {
-# if(on)
-# pp <- .Call(C_Rf_allocS4Object)
-# else
-# pp <- list()
-# .assignOverBinding(".defaultPrototype", where=where, pp, FALSE)
-#}
-#
-#defaultPrototype <-
-# ## the starting prototype for a non-virtual class
-# ## Should someday be a non-vector sexp type
-# function()
-# .defaultPrototype
-#
-#reconcilePropertiesAndPrototype <-
-# ## makes a list or a structure look like a prototype for the given class.
-# ##
-# ## Specifically, returns a structure with attributes corresponding to the slot
-# ## names in properties and values taken from prototype if they exist there, from
-# ## `new(classi)' for the class, `classi' of the slot if that succeeds, and `NULL'
-# ## otherwise.
-# ##
-# ## The prototype may imply slots not in the properties list. It is not required that
-# ## the extends classes be define at this time. Should it be?
-# function(name, properties, prototype, superClasses, where) {
-# ## the StandardPrototype should really be a type that doesn't behave like
-# ## a vector. But none of the existing SEXP types work. Someday ...
-# StandardPrototype <- defaultPrototype()
-# slots <- validSlotNames(allNames(properties))
-# dataPartClass <- elNamed(properties, ".Data")
-# dataPartValue <- FALSE
-# if(!is.null(dataPartClass) && is.null(.validDataPartClass(dataPartClass, where)))
-# stop(gettextf("in defining class %s, the supplied data part class, %s is not valid (must be a basic class or a virtual class combining basic classes)",
-# dQuote(name), dQuote(dataPartClass)),
-# domain = NA)
-# prototypeClass <- getClass(class(prototype), where = where)
-# if((!is.null(dataPartClass) || length(superClasses))
-# && is.na(match("VIRTUAL", superClasses))) {
-# ## Look for a data part in the superclasses, either an inherited
-# ## .Data slot, or a basic class. Uses the first possibility, warns of conflicts
-# for(cl in superClasses) {
-# clDef <- getClassDef(cl, where = where)
-# if(is.null(clDef))
-# stop(gettextf("no definition was found for superclass %s in the specification of class %s",
-# dQuote(cl), dQuote(name)),
-# domain = NA)
-# thisDataPart <- .validDataPartClass(clDef, where, dataPartClass)
-# if(!is.null(thisDataPart)) {
-# dataPartClass <- thisDataPart
-# if(!is.null(clDef@prototype)) {
-# newObject <- clDef@prototype
-# dataPartValue <- TRUE
-# }
-# }
-# }
-# if(length(dataPartClass)) {
-# if(is.na(match(".Data", slots))) {
-# properties <- c(list(".Data"= dataPartClass), properties)
-# slots <- names(properties)
-# }
-# else if(!extends(elNamed(properties, ".Data"), dataPartClass))
-# stop(gettextf("conflicting definition of data part: .Data = %s, superclass implies %s",
-# dQuote(elNamed(properties, ".Data")),
-# dQuote(dataPartClass)),
-# domain = NA)
-# pslots <- NULL
-# if(is.null(prototype)) {
-# if(dataPartValue)
-# prototype <- newObject
-# else if(isVirtualClass(dataPartClass, where = where))
-# ## the equivalent of new("vector")
-# prototype <- newBasic("logical")
-# else
-# prototype <- new(dataPartClass)
-# prototypeClass <- getClass(class(prototype), where = where)
-# }
-# else {
-# if(extends(prototypeClass, "classPrototypeDef")) {
-# hasDataPart <- identical(prototype@dataPart, TRUE)
-# if(!hasDataPart) {
-# if(!dataPartValue) # didn't get a .Data object
-# newObject <- new(dataPartClass)
-# pobject <- prototype@object
-# ## small amount of head-standing to preserve
-# ## any attributes in newObject & not in pobject
-# anames <- names(attributes(pobject))
-# attributes(newObject)[anames] <- attributes(pobject)
-# prototype@object <- newObject
-# }
-# else if(!extends(getClass(class(prototype@object), where = where)
-# , dataPartClass))
-# stop(gettextf("a prototype object was supplied with object slot of class %s, but the class definition requires an object that is class %s",
-# dQuote(class(prototype@object)),
-# dQuote(dataPartClass)),
-# domain = NA)
-# }
-# else if(!extends(prototypeClass, dataPartClass))
-# stop(gettextf("a prototype was supplied of class %s, but the class definition requires an object that is class %s",
-# dQuote(class(prototype)),
-# dQuote(dataPartClass)),
-# domain = NA)
-# }
-# }
-# if(is.null(prototype)) { ## non-vector (may extend NULL)
-# prototype <- StandardPrototype
-# }
-# }
-# ## check for conflicts in the slots
-# allProps <- properties
-# for(i in seq_along(superClasses)) {
-# cl <- superClasses[[i]]
-# clDef <- getClassDef(cl, where)
-# if(is(clDef, "classRepresentation")) {
-# theseProperties <- getSlots(clDef)
-# theseSlots <- names(theseProperties)
-# theseSlots <- theseSlots[theseSlots == ".Data"] # handled already
-# dups <- !is.na(match(theseSlots, allProps))
-# for(dup in theseSlots[dups])
-# if(!extends(elNamed(allProps, dup), elNamed(theseProperties, dup)))
-# stop(gettextf("slot %s in class %s currently defined (or inherited) as \"%s\", conflicts with an inherited definition in class %s",
-# sQuote(dup),
-# dQuote(name),
-# elNamed(allProps, dup),
-# dQuote(cl)),
-# domain = NA)
-# theseSlots <- theseSlots[!dups]
-# if(length(theseSlots))
-# allProps[theseSlots] <- theseProperties[theseSlots]
-# }
-# else
-# stop(gettextf("class %s extends an undefined class (%s)",
-# dQuote(name), dQuote(cl)),
-# domain = NA)
-# }
-# if(is.null(dataPartClass)) {
-# if(extends(prototypeClass, "classPrototypeDef"))
-# {}
-# else {
-# if(is.list(prototype))
-# prototype <- do.call("prototype", prototype)
-# if(is.null(prototype))
-# prototype <- StandardPrototype
-# }
-# }
-# else {
-# dataPartDef <- getClass(dataPartClass)
-# checkDataPart <- !isXS3Class(dataPartDef)
-# if(checkDataPart)
-# checkDataPart <-
-# ((is.na(match(dataPartClass, .BasicClasses)) &&
-# !isVirtualClass(dataPartDef)) || length(dataPartDef@slots))
-# if(checkDataPart)
-# stop(gettextf("%s is not eligible to be the data part of another class (must be a basic class or a virtual class with no slots)",
-# dQuote(dataPartClass)),
-# domain = NA)
-# if(extends(prototypeClass, "classPrototypeDef"))
-# {}
-# else if(extends(prototypeClass, dataPartClass)) {
-# if(extends(prototypeClass, "list") && length(names(prototype)))
-# warning("prototype is a list with named elements (could be ambiguous): better to use function prototype() to avoid trouble.")
-# }
-# else if(is.list(prototype))
-# prototype <- do.call("prototype", prototype)
-# }
-# ## pnames will be the names explicitly defined in the prototype
-# if(extends(prototypeClass, "classPrototypeDef")) {
-# pnames <- prototype@slots
-# prototype <- prototype@object
-# if(length(superClasses) == 0L && any(is.na(match(pnames, slots))))
-# stop(sprintf(ngettext(sum(is.na(match(pnames, slots))),
-# "named elements of prototype do not correspond to slot name: %s",
-# "named elements of prototype do not correspond to slot names: %s"),
-# paste(.dQ(pnames[is.na(match(pnames, slots))]),
-# collapse =", ")),
-# domain = NA)
-# }
-# else
-# pnames <- allNames(attributes(prototype))
-# ## now set the slots not yet in the prototype object.
-# ## An important detail is that these are
-# ## set using slot<- with check=FALSE (because the slot will not be there already)
-# ## what <- is.na(match(slots, pnames))
-# what <- seq_along(properties)
-# props <- properties[what]
-# what <- slots[what]
-# nm <- names(attributes(prototype))
-# for(i in seq_along(what)) {
-# propName <- el(what, i)
-# if(!identical(propName, ".Data") && !propName %in% nm)
-## is.null(attr(prototype, propName)))
-# slot(prototype, propName, FALSE) <- tryNew(el(props, i), where)
-# }
-# list(properties = properties, prototype = prototype)
-#}
-#
-#tryNew <-
-# ## Tries to generate a new element from this class, but if
-# ## the class is undefined just returns NULL.
-# ##
-# ## For virtual classes, returns the class prototype
-# ## so that the object is valid member of class.
-# ## Otherwise tries to generate a new() object, but in rare
-# ## cases, this might fail if the install() method required
-# ## an argument, so this case is trapped as well.
-# function(Class, where)
-#{
-# ClassDef <- getClassDef(Class, where)
-# if(is.null(ClassDef))
-# return(NULL)
-# else if(identical(ClassDef@virtual, TRUE))
-# ClassDef@prototype
-# else tryCatch(new(ClassDef),
-# error = function(e) {
-# value <- ClassDef@prototype
-# class(value) <- ClassDef@className
-# value
-# })
-#}
-#
-#empty.dump <- function() list()
-#
-#isClassDef <- function(object) is(object, "classRepresentation")
-#
-#showClass <-
-# ## print the information about a class definition.
-# ## If complete==TRUE, include the indirect information about extensions.
-# function(Class, complete = TRUE, propertiesAreCalled = "Slots")
-#{
-# if(isClassDef(Class)) {
-# ClassDef <- Class
-# Class <- ClassDef@className
-# }
-# else if(complete)
-# ClassDef <- getClass(Class)
-# else
-# ClassDef <- getClassDef(Class)
-# cat(if(identical(ClassDef@virtual, TRUE)) "Virtual ",
-# "Class ", .dQ(Class),
-# ## Show the package if that is non-trivial:
-# if(nzchar(pkg <- ClassDef@package))
-# c(" [", if(pkg != ".GlobalEnv") "package" else "in", " \"", pkg,"\"]"),
-# "\n", sep="")
-# x <- ClassDef@slots
-# if(length(x)) {
-# printPropertiesList(x, propertiesAreCalled)
-# }
-# else
-# cat("\nNo ", propertiesAreCalled, ", prototype of class \"",
-# .class1(ClassDef@prototype), "\"\n", sep="")
-# ext <- ClassDef@contains
-# if(length(ext)) {
-# cat("\nExtends: ")
-# showExtends(ext)
-# }
-# ext <- ClassDef@subclasses
-# if(length(ext)) {
-# cat("\nKnown Subclasses: ")
-# showExtends(ext)
-# }
-#}
-#
-#printPropertiesList <- function(x, propertiesAreCalled) {
-# if(length(x)) {
-# n <- length(x)
-# cat("\n",propertiesAreCalled, ":\n", sep="")
-# text <- format(c(names(x), as.character(x)), justify="right")
-# text <- matrix(text, nrow = 2L, ncol = n, byrow = TRUE)
-# dimnames(text) <- list(c("Name:", "Class:"), rep.int("", n))
-# print(text, quote = FALSE)
-# }
-#}
-#
-#showExtends <-
-# ## print the elements of the list of extensions. Also used to print
-# ## extensions recorded in the opposite direction, via a subclass list
-# function(ext, printTo = stdout())
-#{
-# what <- names(ext)
-# how <- character(length(ext))
-# for(i in seq_along(ext)) {
-# eli <- el(ext, i)
-# if(is(eli, "SClassExtension")) {
-# how[i] <-
-# if(length(eli@by))
-# paste("by class", paste0("\"", eli@by, "\", distance ",
-# eli@distance, collapse = ", "))
-# else if(identical(eli@dataPart, TRUE))
-# "from data part"
-# else "directly"
-# if(!eli@simple) {
-# if(is.function(eli@test) && !identical(body(eli@test), TRUE)) {
-# how[i] <-
-# paste(how[i], if(is.function(eli@coerce))
-# ", with explicit test and coerce" else
-# ", with explicit test", sep="")
-# }
-# else if(is.function(eli@coerce))
-# how[i] <- paste0(how[i], ", with explicit coerce")
-# }
-# }
-# }
-# if(identical(printTo, FALSE))
-# list(what = what, how = how)
-# else if(all(!nzchar(how)) || all(how == "directly")) {
-# what <- paste0('"', what, '"')
-# if(length(what) > 1L)
-# what <- c(paste0(what[-length(what)], ","), what[[length(what)]])
-# cat(file = printTo, what, fill=TRUE)
-# }
-# else cat(file = printTo, "\n",
-# paste0("Class \"", what, "\", ", how, "\n"), sep = "")
-#}
-#
-#
-#
-#printClassRepresentation <-
-# function(x, ...)
-# showClass(x, propertiesAreCalled="Slots")
-#
-### bootstrap definition to be used before getClass() works
-#possibleExtends <- function(class1, class2, ClassDef1, ClassDef2)
-# .identC(class1, class2) || .identC(class2, "ANY")
-#
-### "Real" definition (assigned in ./zzz.R )
-#.possibleExtends <-
-# ## Find the information that says whether class1 extends class2,
-# ## directly or indirectly. This can be either a logical value or
-# ## an object containing various functions to test and/or coerce the relationship.
-# ## TODO: convert into a generic function w. methods WHEN dispatch is really fast!
-# function(class1, class2, ClassDef1 = getClassDef(class1),
-# ClassDef2 = getClassDef(class2, where = .classEnv(ClassDef1)))
-#{
-# if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
-# return(TRUE)
-# ext <- TRUE # may become a list of extends definitions
-# if(is.null(ClassDef1)) # class1 not defined
-# return(FALSE)
-# ## else
-# ext <- ClassDef1@contains
-# nm1 <- names(ext)
-# i <- match(class2, nm1)
-# if(is.na(i)) {
-# ## look for class1 in the known subclasses of class2
-# if(!is.null(ClassDef2)) {
-# ext <- ClassDef2@subclasses
-# ## check for a classUnion definition, not a plain "classRepresentation"
-# if(!.identC(class(ClassDef2), "classRepresentation") &&
-# isClassUnion(ClassDef2))
-# ## a simple TRUE iff class1 or one of its superclasses belongs to the union
-# i <- as.logical(anyDuplicated(c(class1, unique(nm1),
-# names(ext))))
-# else {
-# ## class1 could be multiple classes here.
-# ## I think we want to know if any extend
-# i <- match(class1, names(ext))
-# ii <- i[!is.na(i)]
-# i <- if(length(ii)) ii[1L] else i[1L]
-# }
-# }
-# }
-# if(is.na(i))
-# FALSE
-# else if(is.logical(i))
-# i
-# else
-# el(ext, i)
-#}
-#
-### complete the extends information in the class definition, by following
-### transitive chains.
-###
-### Elements in the immediate extends list may be added and current elements may be
-### replaced, either by replacing a conditional relation with an unconditional
-### one, or by adding indirect relations.
-###
-#completeExtends <- function(ClassDef, class2, extensionDef, where) {
-# ## check for indirect extensions => already completed
-# ext <- ClassDef@contains
-# for(i in seq_along(ext)) {
-# if(.isIndirectExtension(ext[[i]])) {
-# ClassDef <- .uncompleteClassDefinition(ClassDef, "contains")
-# break
-# }
-# }
-# exts <- .walkClassGraph(ClassDef, "contains", where, attr(ext, "conflicts"))
-# if(length(exts)) {
-# ## ## sort the extends information by depth (required for method dispatch)
-# ## superClassNames <- getAllSuperClasses(ClassDef, FALSE)
-# ## ## FIXME: getAllSuperClassses sometimes misses. Why?
-# ## if(length(superClassNames) == length(exts))
-# ## exts <- exts[superClassNames]
-# if("oldClass" %in% names(exts) &&
-# length(ClassDef@slots) > 1L) # an extension of an S3 class
-# exts <- .S3Extends(ClassDef, exts, where)
-# }
-# if(!missing(class2) && length(ClassDef@subclasses)) {
-# strictBy <- TRUE # FIXME: would like to make this conditional but a safe condition is unknown
-# subclasses <-
-# .transitiveSubclasses(ClassDef@className, class2, extensionDef, ClassDef@subclasses, strictBy)
-# ## insert the new is relationship, but without any recursive completion
-# ## (asserted not to be needed if the subclass slot is complete)
-# for(i in seq_along(subclasses)) {
-# obji <- subclasses[[i]]
-# ## don't override existing relations
-# ## TODO: have a metric that picks the "closest" relationship
-# if(!extends(obji@subClass, class2))
-# setIs(obji@subClass, class2, extensionObject = obji, doComplete = FALSE,
-# where = where)
-# }
-# }
-# ## TODO: move these checks to a tool used by check & conditional on no .S3Class slot
-# ## S3Class <- attr(ClassDef@prototype, ".S3Class")
-# ## if(!is.null(S3Class)) {
-# ## others <- c(ClassDef@className, names(exts))
-# ## others <- others[is.na(match(others, S3Class))]
-# ## if(length(others)>0)
-# ## .checkS3forClass(ClassDef@className, where, others)
-# ## }
-# exts
-#}
-#
-#completeSubclasses <-
-# function(classDef, class2, extensionDef, where, classDef2 = getClassDef(class2, where)) {
-# ## check for indirect extensions => already completed
-# ext <- classDef@subclasses
-# for(i in seq_along(ext)) {
-# if(.isIndirectExtension(ext[[i]])) {
-# classDef <- .uncompleteClassDefinition(classDef, "subclasses")
-# break
-# }
-# }
-# subclasses <- .walkClassGraph(classDef, "subclasses", where)
-# if(!missing(class2) && length(classDef@contains)) {
-# strictBy <- TRUE
-# contains <-
-# .transitiveExtends(class2, classDef@className, extensionDef, classDef@contains, strictBy)
-# ## insert the new is relationship, but without any recursive completion
-# ## (asserted not to be needed if the subclass slot is complete)
-# for(i in seq_along(contains)) {
-# obji <- contains[[i]]
-# cli <- contains[[i]]@superClass
-# cliDef <- getClassDef(cli, where)
-# ## don't override existing relations
-# ## TODO: have a metric that picks the "closest" relationship
-# if(!extends(classDef2, cliDef))
-# setIs(class2, cli, extensionObject = obji,
-# doComplete = FALSE, where = where)
-# }
-# }
-# subclasses
-#}
-#
-#
-### utility function to walk the graph of super- or sub-class relationships
-### in order to incorporate indirect relationships
-#.walkClassGraph <- function(ClassDef, slotName, where, conflicts = character())
-#{
-# ext <- slot(ClassDef, slotName)
-# if(length(ext) == 0)
-# return(ext)
-# className <- ClassDef@className
-# ## the super- vs sub-class is identified by the slotName
-# superClassCase <- identical(slotName, "contains")
-# what <- names(ext)
-# for(i in seq_along(ext)) { # note that this loops only over the original ext
-# by <- what[[i]]
-# if(isClass(by, where = where)) {
-# byDef <- getClass(by, where = where)
-# exti <- slot(byDef, slotName)
-# coni <- attr(exti, "conflicts") # .resolveSuperclasses makes this
-# if(superClassCase && length(coni) > 0) {
-# conflicts <- unique(c(conflicts, coni))
-# }
-# ## add in those classes not already known to be super/subclasses
-# exti <- exti[is.na(match(names(exti), what))]
-# if(length(exti)) {
-# if(superClassCase) {
-# strictBy <- TRUE # FIXME: need to find some safe test allowing non-strict
-# exti <- .transitiveExtends(className, by, ext[[i]], exti, strictBy)
-# }
-# else {
-# strictBy <- TRUE
-# exti <- .transitiveSubclasses(by, className, ext[[i]], exti, strictBy)
-# }
-# ext <- c(ext, exti)
-# }
-# }
-# else
-# stop(gettextf("the '%s' list for class %s, includes an undefined class %s",
-# if(superClassCase) "superClass" else "subClass",
-# dQuote(className),
-# dQuote(.className(by))),
-# domain = NA)
-# }
-# what <- names(ext) ## the direct and indirect extensions
-# if(!all(is.na(match(what, className)))) {
-# ok <- is.na(match(what, className))
-# ## A class may not contain itself, directly or indirectly
-# ## but a non-simple cyclic relation, involving setIs, is allowed
-# for(i in seq_along(what)[!ok]) {
-# exti <- ext[[i]]
-# if(!is(exti, "conditionalExtension")) {
-# if(superClassCase) {
-# whatError <- "contain itself"
-# }
-# else {
-# whatError <- "have itself as a subclass"
-# }
-# ## this is not translatable
-# stop(sprintf("class %s may not %s: it contains class %s, with a circular relation back to %s",
-# dQuote(className), whatError,
-# dQuote(exti@by),
-# dQuote(className)),
-# domain = NA)
-# }
-# }
-# ext <- ext[ok]
-# }
-# ## require superclasses to be sorted by distance
-# distOrder <- sort.list(sapply(ext, function(x)x@distance))
-# ext <- ext[distOrder]
-# if(superClassCase && (anyDuplicated(what) || length(conflicts) > 0))
-# ext <- .resolveSuperclasses(ClassDef, ext, where, conflicts)
-# ext
-#}
-#
-#.reportSuperclassConflicts <- function(className, ext, where) {
-# what <- names(ext)
-# conflicts <- character()
-# for(i in seq_along(ext)) {
-# by <- what[[i]]
-# ## report only the direct superclass from which inconsistencies are inherited
-# if(identical(ext[[i]]@distance, 1) && isClass(by, where = where)) {
-# byDef <- getClass(by, where = where)
-# exti <- byDef@contains
-# coni <- attr(exti, "conflicts") # .resolveSuperclasses makes this
-# if( length(coni) > 0) {
-# warning(gettextf("class %s is inheriting an inconsistent superclass structure from class %s, inconsistent with %s",
-# .dQ(className), .dQ(by),
-# paste(.dQ(coni), collapse = ", ")),
-# call. = FALSE, domain = NA)
-# conflicts <- unique(c(conflicts, coni))
-# }
-# }
-# }
-# newconflicts <- attr(ext, "conflicts")
-# if(length(newconflicts) > length(conflicts))
-# warning(gettextf("unable to find a consistent ordering of superclasses for class %s: order chosen is inconsistent with the superclasses of %s",
-# .dQ(className),
-# paste(.dQ(setdiff(newconflicts, conflicts)),
-# collapse = ", ")),
-# call. = FALSE, domain = NA)
-#}
-#
-#
-#.resolveSuperclasses <- function(classDef, ext, where, conflicts = attr(ext, "conflicts")) {
-# ## find conditional extensions, ignored in superclass ordering
-# .condExts <- function(contains)
-# sapply(contains, function(x) is(x, "conditionalExtension" ))
-# .noncondExtsClass <- function(cl) {
-# if(isClass(cl, where = where) ) {
-# contains <- getClass(cl, where = where)@contains
-# names(contains)[!.condExts(contains)]
-# }
-# else cl
-# }
-# what <- names(ext)
-# dups <- unique(what[duplicated(what)])
-# if(length(dups) > 0) {
-# ## First, eliminate all conditional relations, which never override non-conditional
-# affected <- match(what, dups, 0) > 0
-# conditionals <- .condExts(ext)
-# if(any(conditionals)) {
-# affected[conditionals] <- FALSE
-# what2 <- what[affected]
-# dups <- unique(what2[duplicated(what2)])
-# if(length(dups) == 0) {
-# ## eliminating conditonal relations removed duplicates
-# if(length(conflicts) > 0)
-# attr(ext, "conflicts") <- unique(c(conflicts, attr(ext, "conflicts")))
-# return(ext)
-# }
-# ## else, go on with conditionals eliminated
-# }
-# directSupers <- sapply(classDef@contains, function(x) identical(x@distance, 1))
-# directSupers <- unique(names(classDef@contains[directSupers]))
-# ## form a list of the superclass orderings of the direct superclasses
-# ## to check consistency with each way to eliminate duplicates
-# ## Once again, conditional relations are eliminated
-# superExts <- lapply(directSupers, .noncondExtsClass)
-# names(superExts) <- directSupers
-# retain = .choosePos(classDef@className, what, superExts, affected)
-# if(is.list(retain)) {
-# these <- retain[[2]]
-# conflicts <- unique(c(conflicts, these)) # append the new conflicts
-# retain <- retain[[1]]
-# }
-# ## eliminate the affected & not retained
-# affected[retain] <- FALSE
-# ext <- ext[!affected]
-# }
-# ## even if no dups here, may have inherited some conflicts,
-# ## which will be copied to the contains list.
-# ## FUTURE NOTE (7/09): For now, we are using an attribute for conflicts,
-# ## rather than promoting the ext list to a new class, which may be desirable
-# ## if other code comes to depend on the conflicts information.
-# attr(ext, "conflicts") <- conflicts
-# ext
-#}
-
-classMetaName <-
- ## a name for the object storing this class's definition
- function(name)
- methodsPackageMetaName("C", name)
-
-## regexp for matching class metanames; semi-general but assumes the
-## meta pattern starts with "." and has no other special characters
-#.ClassMetaPattern <- function()
-# paste0("^[.]",substring(methodsPackageMetaName("C",""),2))
-
-##FIXME: C code should take multiple strings in name so paste() calls could be avoided.
-methodsPackageMetaName <-
- ## a name mangling device to simulate the meta-data in S4
- function(prefix, name, package = "")
- ## paste(".", prefix, name, sep="__") # too slow
- .Call(C_R_methodsPackageMetaName, prefix, name, package)
-
-### a non-exported regexp that matches methods metanames
-### This is quite general and matches all patterns that could be generated
-### by calling methodsPackageMetaName() with a sequence of capital Latin letters
-### Used by package.skeleton in utils
-#.methodsPackageMetaNamePattern <- "^[.]__[A-Z]+__"
-#
-#requireMethods <-
-# ## Require a subclass to implement methods for the generic functions, for this signature.
-# ##
-# ## For each generic, `setMethod' will be called to define a method that throws an error,
-# ## with the supplied message.
-# ##
-# ## The `requireMethods' function allows virtual classes to require actual classes that
-# ## extend them to implement methods for certain functions, in effect creating an API
-# ## for the virtual class. Otherwise, default methods for the corresponding function would
-# ## be called, resulting in less helpful error messages or (worse still) silently incorrect
-# ## results.
-# function(functions, signature,
-# message = "", where = topenv(parent.frame()))
-#{
-# for(f in functions) {
-# method <- getMethod(f, optional = TRUE)
-# if(!is.function(method))
-# method <- getGeneric(f, where = where)
-# body(method) <- substitute(stop(methods:::.missingMethod(FF, MESSAGE, if(exists(".Method")).Method else NULL), domain=NA), list(FF=f, MESSAGE=message))
-# environment(method) <- .GlobalEnv
-# setMethod(f, signature, method, where = where)
-# }
-# NULL
-#}
-#
-### Construct an error message for an unsatisfied required method.
-#.missingMethod <- function(f, message = "", method) {
-# if(nzchar(message))
-# message <- paste0("(", message, ")")
-# message <- paste("for function", f, message)
-# if(is(method, "MethodDefinition")) {
-# target <- paste(.dQ(method@target), collapse=", ")
-# defined <- paste(.dQ(method@defined), collapse=", ")
-# message <- paste("Required method", message, "not defined for signature",
-# target)
-# if(!identical(target, defined))
-# message <- paste(message, ", required for signature", defined)
-# }
-# else message <- paste("Required method not defined", message)
-# message
-#}
-#
-#getSlots <- function(x) {
-# classDef <- if(isClassDef(x)) x else getClass(x)
-# props <- classDef@slots
-# value <- as.character(props)
-# names(value) <- names(props)
-# value
-#}
-#
-#
-### check for reserved slot names. Currently only "class" is reserved
-#validSlotNames <- function(names) {
-# if(is.na(match("class", names)))
-# names
-# else
-# stop("\"class\" is a reserved slot name and cannot be redefined")
-#}
-#
-#### utility function called from primitive code for "@"
-#getDataPart <- function(object) {
-# if(identical(typeof(object),"S4")) {
-# ## explicit .Data or .xData slot
-# ## Some day, we may merge both of these as .Data
-# value <- attr(object, ".Data")
-# if(is.null(value)) {
-# value <- attr(object, ".xData")
-# if(is.null(value))
-# stop("Data part is undefined for general S4 object")
-# }
-# if(identical(value, .pseudoNULL))
-# return(NULL)
-# else
-# return(value)
-# }
-# temp <- getClass(class(object))@slots
-# if(length(temp) == 0L)
-# return(object)
-# if(is.na(match(".Data", names(temp))))
-# stop(gettextf("no '.Data' slot defined for class %s",
-# dQuote(class(object))),
-# domain = NA)
-# dataPart <- temp[[".Data"]]
-# switch(dataPart,
-# ## the common cases, for efficiency
-# numeric = , vector = , integer = , character = , logical = ,
-# complex = , list =
-# attributes(object) <- NULL,
-# matrix = , array = {
-# value <- object
-# attributes(value) <- NULL
-# attr(value, "dim") <- attr(object, "dim")
-# attr(value, "dimnames") <- attr(object, "dimnames")
-# object <- value
-# },
-# ts = {
-# value <- object
-# attributes(value) <- NULL
-# attr(value, "ts") <- attr(object, "ts")
-# object <- value
-# },
-# ## default:
-# if(is.na(match(dataPart, .BasicClasses))) {
-# ## keep attributes not corresponding to slots
-# attrVals <- attributes(object)
-# attrs <- names(attrVals)
-# attrs <- attrs[is.na(match(attrs, c("class", names(temp))))]
-# attributes(object) <- attrVals[attrs]
-# }
-# else
-# ## other basic classes have no attributes
-# attributes(object) <- NULL
-# )
-# object
-#}
-#
-#setDataPart <- function(object, value, check = TRUE) {
-# if(check || identical(typeof(object), "S4")) {
-# classDef <- getClass(class(object))
-# slots <- getSlots(classDef)
-# dataSlot <- .dataSlot(names(slots))
-# if(length(dataSlot) == 1)
-# dataClass <- elNamed(slots, dataSlot)
-# else if(check)
-# stop(gettextf("class %s does not have a data part (a .Data slot) defined",
-# dQuote(class(object))),
-# domain = NA)
-# else # this case occurs in making the methods package. why?
-# return(.mergeAttrs(value, object))
-# value <- as(value, dataClass) # note that this is strict as()
-# if(identical(typeof(object), "S4")) {
-# if(is.null(value))
-# value <- .pseudoNULL
-# attr(object, dataSlot) <- value
-# return(object)
-# }
-# }
-# .mergeAttrs(value, object)
-#}
-#
-#.validDataPartClass <- function(cl, where, prevDataPartClass = NULL) {
-# if(is(cl, "classRepresentation")) {
-# ClassDef <- cl
-# cl <- ClassDef@className
-# }
-# else
-# ClassDef <- getClass(cl, TRUE)
-#
-# switch(cl, matrix = , array = value <- cl,
-# value <- elNamed(ClassDef@slots, ".Data"))
-# if(is.null(value)) {
-# if(.identC(cl, "structure"))
-# value <- "vector"
-# else if((extends(cl, "vector") || !is.na(match(cl, .BasicClasses))))
-# value <- cl
-# else if(extends(cl, "oldClass") && isVirtualClass(cl)) {
-# }
-# else if(identical(ClassDef@virtual, TRUE) &&
-# length(ClassDef@slots) == 0L &&
-# length(ClassDef@subclasses) ) {
-# ## look for a union of basic classes
-# subclasses <- ClassDef@subclasses
-# what <- names(subclasses)
-# value <- cl
-# for(i in seq_along(what)) {
-# ext <- subclasses[[i]]
-# ##TODO: the following heuristic test for an "original"
-# ## subclass should be replaced by a suitable class (extending SClassExtension)
-# if(length(ext@by) == 0L && ext@simple && !ext@dataPart &&
-# is.na(match(what[i], .BasicClasses))) {
-# value <- NULL
-# break
-# }
-# }
-# }
-# }
-# if(!(is.null(value) || is.null(prevDataPartClass) || extends(prevDataPartClass, value) ||
-# isVirtualClass(value, where = where))) {
-# warning(gettextf("more than one possible class for the data part: using %s rather than %s",
-# .dQ(prevDataPartClass), .dQ(value)), domain = NA)
-# value <- NULL
-# }
-# value
-#}
-#
-#.dataSlot <- function(slotNames) {
-# dataSlot <- c(".Data", ".xData")
-# dataSlot <- dataSlot[match(dataSlot, slotNames, 0)>0]
-# if(length(dataSlot) > 1)
-# stop("class cannot have both an ordinary and hidden data type")
-# dataSlot
-#}
-#
-#
-#.mergeAttrs <- function(value, object, explicit = NULL) {
-# supplied <- attributes(object)
-# if(length(explicit))
-# supplied[names(explicit)] <- explicit
-# valueAttrs <- attributes(value)
-# ## names are special.
-# if(length(supplied$names) && length(valueAttrs$names) == 0L) {
-# if(length(value) != length(object))
-# length(supplied$names) <- length(value)
-# }
-# if(length(valueAttrs)) { ## don't overwrite existing attrs
-# valueAttrs$class <- NULL ## copy in class if it's supplied
-# supplied[names(valueAttrs)] <- valueAttrs
-# } ## else -- nothing to protect
-# attributes(value) <- supplied
-# if(isS4(object))
-# .asS4(value)
-# else
-# value
-#}
-#
-#.newExternalptr <- function()
-# .Call(C_R_externalptr_prototype_object)
-#
-### modify the list moreExts, currently from class `by', to represent
-### extensions instead from an originating class; byExt is the extension
-### from that class to `by'
-#.transitiveExtends <- function(from, by, byExt, moreExts, strictBy) {
-# what <- names(moreExts)
-# ### if(!strictBy) message("Extends: ",from, ": ", paste(what, collapse = ", "))
-# for(i in seq_along(moreExts)) {
-# toExt <- moreExts[[i]]
-# to <- what[[i]]
-# toExt <- .combineExtends(byExt, toExt, by, to, strictBy)
-# moreExts[[i]] <- toExt
-# }
-# moreExts
-# ### if(!strictBy) message("Done")
-#}
-#
-#.transitiveSubclasses <- function(by, to, toExt, moreExts, strictBy) {
-# what <- names(moreExts)
-# ### if(!strictBy) message("Subclasses: ",by, ": ", paste(what, collapse = ", "))
-# for(i in seq_along(moreExts)) {
-# byExt <- moreExts[[i]]
-# byExt <- .combineExtends(byExt, toExt, by, to, strictBy)
-# moreExts[[i]] <- byExt
-# }
-# moreExts
-# ### if(!strictBy) message("Done")
-#}
-#
-#.combineExtends <- function(byExt, toExt, by, to, strictBy) {
-# ## construct the composite coerce method, taking into account the strict=
-# ## argument.
-# f <- toExt@coerce
-# fR <- toExt@replace
-# toExpr <- body(f)
-# fBy <- byExt@coerce
-# byExpr <- body(fBy)
-# ## if both are simple extensions, so is the composition
-# if(byExt@simple && toExt@simple) {
-# expr <- (if(byExt@dataPart)
-# substitute({if(strict) from <- from@.Data; EXPR},
-# list(EXPR = toExpr))
-# else if(toExt@dataPart)
-# substitute({from <- EXPR; if(strict) from@.Data},
-# list(EXPR = byExpr))
-# else (if(identical(byExpr, quote(from)) && identical(toExpr, quote(from)))
-# quote(from)
-# else
-# substitute({from <- E1; E2}, list(E1 = byExpr, E2 = toExpr))
-# )
-# )
-# body(f, envir = environment(f)) <- expr
-# }
-# else {
-# toExt@simple <- FALSE
-# if(!identical(byExpr, quote(from)))
-# body(f, envir = environment(f)) <-
-# substitute( {from <- as(from, BY, strict = strict); TO},
-# list(BY = by, TO = toExpr))
-# }
-# toExt@coerce <- f
-# f <- toExt@test
-# toExpr <- body(f)
-# byExpr <- body(byExt@test)
-# ## process the test code
-# if(!identical(byExpr, TRUE)) {
-# if(!identical(toExpr, TRUE))
-# body(f, envir = environment(f)) <- substitute((BY) && (TO),
-# list(BY = byExpr, TO = toExpr))
-# else
-# body(f, envir = environment(f)) <- byExpr
-# }
-# toExt@test <- f
-# f <- byExt@replace
-# byExpr <- body(f)
-# if(!strictBy) {
-# toDef <- getClassDef(to)
-# byDef <- getClassDef(by)
-# strictBy <- is.null(toDef) || is.null(byDef) || toDef@virtual || byDef@virtual
-# }
-# ## Is there a danger of infinite loop below?
-# expr <- substitute({.value <- as(from, BY, STRICT); as(.value, TO) <- value; value <- .value; BYEXPR},
-# list(BY=by, TO = to, BYEXPR = byExpr, STRICT = strictBy))
-# body(f, envir = environment(f)) <- expr
-# toExt@replace <- f
-# toExt@by <- toExt@subClass
-# toExt@subClass <- byExt@subClass
-# toExt@distance <- toExt@distance + byExt@distance
-# ## the combined extension is conditional if either to or by is conditional
-# if(is(byExt, "conditionalExtension") && !is(toExt, "conditionalExtension"))
-# class(toExt) <- class(byExt)
-# toExt
-#}
-#
-### construct the expression that implements the computations for coercing
-### an object to one of its superclasses
-### The fromSlots argument is provided for calls from makeClassRepresentation
-### and completeClassDefinition,
-### when the fromClass is in the process of being defined, so slotNames() would fail
-#.simpleCoerceExpr <- function(fromClass, toClass, fromSlots, toDef) {
-# toSlots <- names(toDef@slots)
-# sameSlots <- (length(fromSlots) == length(toSlots) &&
-# !any(is.na(match(fromSlots, toSlots))))
-# if(!isVirtualClass(toDef))
-# toClass <- class(new(toDef)) # get it with the package slot correct
-# if(sameSlots)
-# substitute({class(from) <- CLASS; from}, list(CLASS = toClass))
-# else if(length(toSlots) == 0L) {
-# ## either a basic class or something with the same representation
-# if(is.na(match(toClass, .BasicClasses)))
-# substitute({ attributes(from) <- NULL; class(from) <- CLASS; from},
-# list(CLASS = toClass))
-# else if(isVirtualClass(toDef))
-# quote(from)
-# else {
-# ## a basic class; a vector type, matrix, array, or ts
-# switch(toClass,
-# matrix = , array = {
-# quote({.dm <- dim(from); .dn <- dimnames(from)
-# attributes(from) <- NULL; dim(from) <- .dm
-# dimnames(from) <- .dn; from})
-# },
-# ts = {
-# quote({.tsp <- tsp(from); attributes(from) <- NULL
-# tsp(from) <- .tsp; class(from) <- "ts"; from})
-# },
-# quote({attributes(from) <- NULL; from})
-# )
-# }
-# }
-# else {
-# substitute({ value <- new(CLASS)
-# for(what in TOSLOTS)
-# slot(value, what) <- slot(from, what)
-# value },
-# list(CLASS = toClass, TOSLOTS = toSlots))
-# }
-#}
-#
-#.simpleReplaceExpr <- function(toDef) {
-# toSlots <- names(toDef@slots)
-# substitute({
-# for(what in TOSLOTS)
-# slot(from, what) <- slot(value, what)
-# from
-# }, list(TOSLOTS = toSlots))
-#}
-#
-### the boot version of newClassRepresentation (does no checking on slots to avoid
-### requiring method selection on coerce).
-#
-#newClassRepresentation <- function(...) {
-# value <- new("classRepresentation")
-# slots <- list(...)
-# slotNames <- names(slots)
-# for(i in seq_along(slotNames))
-# slot(value, slotNames[[i]], FALSE) <- slots[[i]]
-# value
-#}
-#
-### create a temporary definition of a class, but one that is distinguishable
-### (by its class) from the real thing. See comleteClassDefinition
-#.tempClassDef <- function(...) {
-# value <- new("classRepresentation")
-# slots <- list(...)
-# slotNames <- names(slots)
-# for(i in seq_along(slotNames))
-# slot(value, slotNames[[i]], FALSE) <- slots[[i]]
-# value
-#}
-#
-### the real version of newClassRepresentation, assigned in ..First.lib
-#.newClassRepresentation <- function(...)
-# new("classRepresentation", ...)
-#
-#.insertExpr <- function(expr, el) {
-# if(!is(expr, "{"))
-# expr <- substitute({EXPR}, list(EXPR = expr))
-# expr[3L:(length(expr)+1)] <- expr[2L:length(expr)]
-# expr[[2L]] <- el
-# expr
-#}
-#
-### utility guaranteed to return only the first string of the class.
-### Would not be needed if we dis-allowed S3 classes with multiple strings (or
-### if the methods package version of class dropped the extra strings).
-#.class1 <- function(x) {
-# cl <- class(x)
-# if(length(cl) > 1L)
-# cl[[1L]]
-# else
-# cl
-#}
-#
-#substituteFunctionArgs <-
-# function(def, newArgs, args = formalArgs(def), silent = FALSE,
-# functionName = "a function")
-#{
-# if(!identical(args, newArgs)) {
-# if( !missing(functionName) ) # this style does not allow translation
-# functionName <- paste("for", functionName)
-#
-# n <- length(args)
-# if(n != length(newArgs))
-# stop(sprintf("trying to change the argument list of %s with %d arguments to have arguments (%s)",
-# functionName, n, paste(newArgs, collapse = ", ")),
-# domain = NA)
-# bdy <- body(def)
-# ## check for other uses of newArgs
-# checkFor <- newArgs[is.na(match(newArgs, args))]
-# locals <- all.vars(bdy)
-# if(length(checkFor) && any(!is.na(match(checkFor, locals))))
-# stop(sprintf("get rid of variables in definition %s (%s); they conflict with the needed change to argument names (%s)",
-# functionName,
-# paste(checkFor[!is.na(match(checkFor, locals))], collapse = ", "),
-# paste(newArgs, collapse = ", ")), domain = NA)
-# ll <- vector("list", 2L*n)
-# for(i in seq_len(n)) {
-# ll[[i]] <- as.name(args[[i]])
-# ll[[n+i]] <- as.name(newArgs[[i]])
-# }
-# names(ll) <- c(args, newArgs)
-# body(def, envir = environment(def)) <- substituteDirect(bdy, ll)
-# if(!silent) {
-# msg <-
-# sprintf("NOTE: arguments in definition %s changed from (%s) to (%s)",
-# functionName,
-# paste(args, collapse = ", "),
-# paste(newArgs, collapse = ", "))
-# message(msg, domain = NA)
-# }
-# }
-# def
-#}
-#
-#.makeValidityMethod <- function(Class, validity) {
-# if(!is.null(validity)) {
-# if(!is(validity, "function"))
-# stop(gettextf("a validity method must be a function of one argument, got an object of class %s",
-# dQuote(class(validity))),
-# domain = NA)
-# validity <- substituteFunctionArgs(validity, "object", functionName = sprintf("validity method for class '%s'", Class))
-# }
-# validity
-#}
-#
-## the bootstrap version of setting slots in completeClassDefinition
-#.mergeClassDefSlots <- function(ClassDef, ...) {
-# slots <- list(...); slotNames <- names(slots)
-# for(i in seq_along(slots))
-# slot(ClassDef, slotNames[[i]], FALSE) <- slots[[i]]
-# ClassDef
-#}
-#
-### the real version: differs only in checking the slot values
-#..mergeClassDefSlots <- function(ClassDef, ...) {
-# slots <- list(...); slotNames <- names(slots)
-# for(i in seq_along(slots))
-# slot(ClassDef, slotNames[[i]]) <- slots[[i]]
-# ClassDef
-#}
-#
-#### fix the annoying habit of R giving function definitions the local environment by default
-#.gblEnv <- function(f) {
-# environment(f) <- .GlobalEnv
-# f
-#}
-#
-### a utility for makePrototypeFromClassDef that causes inf. recursion if used too early
-#..isPrototype <- function(p)is(p, "classPrototypeDef")
-### the simple version
-#.isPrototype <- function(p) .identC(class(p), "classPrototypeDef")
-#
-#.className <- function(cl) if(is(cl, "classRepresentation")) cl@className else as(cl, "character")
-#
-### bootstrap version: all classes and methods must be in the version of the methods
-### package being built in the toplevel environment: MUST avoid require("methods") !
-#.requirePackage <- function(package, mustFind = TRUE)
-# topenv(parent.frame())
-#
-#.PackageEnvironments <- new.env(hash=TRUE) # caching for required packages
-#
-### real version of .requirePackage
-#..requirePackage <- function(package, mustFind = TRUE) {
-# value <- package
-# if(nzchar(package)) {
-# if(package %in% loadedNamespaces())
-# value <- getNamespace(package)
-# else {
-# if(identical(package, ".GlobalEnv"))
-# return(.GlobalEnv)
-# if(identical(package, "methods"))
-# return(topenv(parent.frame())) # booting methods
-# if(exists(package, envir = .PackageEnvironments, inherits = FALSE))
-# return(get(package, envir = .PackageEnvironments)) #cached, but only if no namespace
-# }
-# }
-# if(is.environment(value))
-# return(value)
-# topEnv <- options()$topLevelEnvironment
-# if(is.null(topEnv))
-# topEnv <- .GlobalEnv
-# if(exists(".packageName", topEnv, inherits=TRUE) &&
-# .identC(package, get(".packageName", topEnv)))
-# return(topEnv) # kludge for source'ing package code
-# if(nzchar(package) && require(package, character.only = TRUE)) {}
-# else {
-# if(mustFind)
-# stop(gettextf("unable to find required package %s",
-# sQuote(package)),
-# domain = NA)
-# else
-# return(NULL)
-# }
-# value <- .asEnvironmentPackage(package)
-# assign(package, value, envir = .PackageEnvironments)
-# value
-#}
-#
-#.classDefEnv <- function(classDef) {
-# .requirePackage(classDef@package)
-#}
-#
-#
-#.asEnvironmentPackage <- function(package) {
-# if(identical(package, ".GlobalEnv"))
-# .GlobalEnv
-# else {
-# ##FIXME: the paste should not be needed
-# pkg <- paste("package", package, sep=":")
-# ## need to allow for versioned installs: prefer exact match.
-# m <- charmatch(pkg, search())
-# if(is.na(m)) # not attached, better be an available namespace
-# getNamespace(package)
-# else
-# as.environment(search()[m])
-# }
-#}
-#
-### bootstrap version, mustn't fail
-#.classEnv <- function(Class, default = .requirePackage("methods"), mustFind = TRUE) {
-# package <- packageSlot(Class)
-# if(is.null(package)) {
-# ## unconditionally use the methods package
-# default
-# }
-# else
-# .requirePackage(package)
-#}
-#
-#
-### to be .classEnv() --- currently used in 'Matrix' (via wrapper)
-#..classEnv <- function(Class, default = .requirePackage("methods"), mustFind = TRUE) {
-# package <- { if(is.character(Class)) packageSlot(Class) else
-# ## must then be a class definition
-# Class@package }
-# if(is.null(package)) {
-# ## use the default, but check that the class is there, and if not
-# ## try a couple of other heuristics
-# value <- default
-# def <- getClassDef(Class, value, NULL)
-# if(is.null(def)) {
-# value <- .GlobalEnv
-# def <- getClassDef(Class, value, NULL)
-# if(is.null(def)) {
-# value <- .requirePackage("methods")
-# if(!identical(default, value)) # user supplied default
-# def <- getClassDef(Class, value, NULL)
-# }
-# }
-# if(is.null(def) && mustFind)
-# stop(gettextf("unable to find an environment containing class %s",
-# dQuote(Class)),
-# domain = NA)
-# value
-# }
-# else
-# .requirePackage(package)
-#}
-#
-### find a generic function reference, using the package slot if present
-### FIXME: this and .classEnv should be combined and implemented in C for speed
-### They differ in that .classEnv uses the class metaname when it searches; i.e.,
-### they use getClassDef and .getGeneric resp. Also, .getEnv returns baseenv() rather
-### than generating an error if no generic found (so getGeneric can return gen'c for prim'ves)
-#
-#.genEnv <- function(f, default = .requirePackage("methods"), package = "")
-#{
-# if(!nzchar(package))
-# package <- packageSlot(f)
-# if(is.null(package)) {
-# ## use the default, but check that the object is there, and if not
-# ## try a couple of other heuristics
-# value <- default
-# def <- .getGeneric(f, value)
-# if(is.null(def)) {
-# value <- .GlobalEnv
-# def <- .getGeneric(f, value)
-# if(is.null(def)) {
-# value <- .requirePackage("methods")
-# if(!identical(default, value)) # user supplied default
-# def <- .getGeneric(f, value)
-# }
-# }
-# if(is.null(def))
-# baseenv()
-# else
-# value
-# }
-# else
-# .requirePackage(package)
-#}
-
-## cache and retrieve class definitions If there is a conflict with
-## packages a list of classes will be cached
-## See .cacheGeneric, etc. for analogous computations for generics
-.classTable <- new.env(TRUE, baseenv())
-assign("#HAS_DUPLICATE_CLASS_NAMES", FALSE, envir = .classTable)
-#.duplicateClassesExist <- function(on) {
-# value <- get("#HAS_DUPLICATE_CLASS_NAMES", envir = .classTable)
-# if(nargs())
-# assign("#HAS_DUPLICATE_CLASS_NAMES", on, envir = .classTable)
-# value
-#}
-#
-#.cacheClass <- function(name, def, doSubclasses = FALSE, env) {
-# if(!identical(doSubclasses, FALSE))
-# .recacheSubclasses(def@className, def, doSubclasses, env)
-# if(exists(name, envir = .classTable, inherits = FALSE)) {
-# newpkg <- def@package
-# prev <- get(name, envir = .classTable)
-# if(is(prev, "classRepresentation")) {
-# if(identical(prev, def))
-# return()
-# pkg <- prev@package # start a per-package list
-# if(identical(pkg, newpkg)) { # redefinition
-# ## cache for S3, to override possible previous cache
-# base:::.cache_class(name, .extendsForS3(def))
-# ## base:::.cache_class(name, extends(def))
-# return(assign(name, def, envir = .classTable))
-# }
-# else if(.simpleDuplicateClass(def, prev))
-# return()
-# prev <- list(prev)
-# names(prev) <- pkg
-# }
-# i <- match(newpkg, names(prev))
-# if(is.na(i))
-# prev[[newpkg]] <- def
-# else if(identical(def, prev[[i]]))
-# return()
-# else
-# prev[[i]] <- def
-# def <- prev
-# .duplicateClassesExist(TRUE)
-# }
-# assign(name, def, envir = .classTable)
-#}
-#
-### test for identical def, prev class definitions
-### An exhaustive test would be very complicated, having to test
-### superclasses in detail, prototypes for the slots, etc.
-#.simpleDuplicateClass <- function(def, prev) {
-# supers <- names(def@contains)
-# prevSupers <- names(prev@contains)
-# if(length(supers) != length(prevSupers) ||
-# any(is.na(match(supers, prevSupers))))
-# return(FALSE)
-# warnLevel <- getOption("warn")
-# S3 <- "oldClass" %in% supers
-# if(S3) {
-# ## it is possible one of these is inconsistent, but unlikely
-# ## and we will get here often from multiple setOldClass(...)'s
-# if(warnLevel)
-# message(gettextf("Note: the specification for S3 class %s in package %s seems equivalent to one from package %s: not turning on duplicate class definitions for this class.",
-# dQuote(def@className),
-# sQuote(def@package),
-# sQuote(prev@package)),
-# domain = NA)
-# return(TRUE)
-# }
-# ## if there are already duplicate classes, we check duplicates
-# ## for the superclasses
-# dupsExist <- .duplicateClassesExist()
-# if(dupsExist) {
-# dups <- match(supers, multipleClasses(), 0) > 0
-# if(any(dups)) {
-# if(warnLevel)
-# message(gettextf("Note: some superclasses of class %s in package %s have duplicate definitions. This definition is not being treated as equivalent to that from package %s",
-# dQuote(def@className),
-# sQuote(def@package),
-# sQuote(prev@package)),
-# domain = NA)
-# return(FALSE)
-# }
-# }
-# ## now check the slots
-# slots <- names(def@slots)
-# prevSlots <- names(prev@slots)
-# if(length(slots) != length(prevSlots) ||
-# any(is.na(match(slots, prevSlots))))
-# return(FALSE)
-# for(what in slots) {
-# slotClasses <- def@slots
-# prevClasses <- prev@slots
-# clWhat <- slotClasses[[what]]
-# prevWhat <- prevClasses[[what]]
-# if(!identical(as.character(clWhat), as.character(prevWhat)) ||
-# (dupsExist && !identical(as.character(packageSlot(clWhat)),
-# as.character(packageSlot(prevWhat)))))
-# return(FALSE)
-# }
-# if(warnLevel)
-# message(gettextf("Note: the specification for class %s in package %s seems equivalent to one from package %s: not turning on duplicate class definitions for this class.",
-# dQuote(def@className),
-# sQuote(def@package),
-# sQuote(prev@package)),
-# domain = NA)
-# TRUE
-#}
-#
-#.uncacheClass <- function(name, def) {
-# if(exists(name, envir = .classTable, inherits = FALSE)) {
-# if(is(def, "classRepresentation")) # paranoia: should only be called this way
-# newpkg <- def@package
-# else
-# newpkg <- ""
-# prev <- get(name, envir = .classTable)
-# if(is(prev, "classRepresentation") &&
-# identical(prev@package, newpkg) )
-# return(remove(list = name, envir = .classTable))
-# i <- match(newpkg, names(prev))
-# if(!is.na(i))
-# prev[[i]] <- NULL
-# else # we might warn about unchaching more than once
-# return()
-# if(length(prev) == 0L)
-# return(remove(list = name, envir = .classTable))
-# else if(length(prev) == 1L)
-# prev <- prev[[1L]]
-# assign(name, prev, envir = .classTable)
-# }
-#}
-
-## the workhorse of class access
-## The underlying C code will return name if it is not a character vector
-## in the assumption this is a classRepresentation or subclass of that.
-## In principle, this could replace the checks on class(name) in getClassDef
-## and new(), which don't work for subclasses of classRepresentation anyway.
-.getClassFromCache <- function(name, where) {
- value <- .Call(C_R_getClassFromCache, name, .classTable)
- if(is.list(value)) { ## multiple classes with this name
- pkg <- packageSlot(name)
- if(is.null(pkg))
- pkg <- if(is.character(where)) where else getPackageName(where, FALSE) # may be ""
- pkgs <- names(value)
- i <- match(pkg, pkgs, 0L)
- if(i == 0L) ## try 'methods':
- i <- match("methods", pkgs, 0L)
- if(i > 0L) value[[i]]
- else NULL
- }
- else #either a class definition or NULL
- value
-}
-
-#### insert superclass information into all the subclasses of this
-#### class. Used to incorporate inheritance information from
-#### ClassUnions
-#.recacheSubclasses <- function(class, def, doSubclasses, env) {
-# subs <- def@subclasses
-# subNames <- names(subs)
-# for(i in seq_along(subs)) {
-# what <- subNames[[i]]
-# subDef <- getClassDef(what, env)
-# if(is.null(subDef))
-# warning(gettextf("undefined subclass %s of class %s; definition not updated",
-# .dQ(what), .dQ(def@className)))
-# else if(is.na(match(what, names(subDef@contains)))) {
-# ## insert the new superclass to maintain order by distance
-# cntns <- subDef@contains
-# cntns[[class]] <- subs[[i]]
-# cntns <- cntns[sort.list(sapply(cntns, function(x)x@distance))]
-# subDef@contains <- cntns
-# .cacheClass(what, subDef, FALSE, env)
-# }
-# }
-# NULL
-#}
-#
-### alternative to .recacheSubclasses, only needed for non-unions
-### Inferior in that nonlocal subclasses will not be updated, hence the
-### warning when the subclass is not in where
-#.checkSubclasses <- function(class, def, class2, def2, where, where2) {
-# where <- as.environment(where)
-# where2 <- as.environment(where2)
-# subs <- def@subclasses
-# subNames <- names(subs)
-# extDefs <- def2@subclasses
-# for(i in seq_along(subs)) {
-# what <- subNames[[i]]
-# if(.identC(what, class2))
-# next # catch recursive relations
-# cname <- classMetaName(what)
-# if(exists(cname, envir = where, inherits = FALSE)) {
-# subDef <- get(cname, envir = where)
-# cwhere <- where
-# }
-# else if(exists(cname, envir = where2, inherits = FALSE)) {
-# subDef <- get(cname, envir = where2)
-# cwhere <- where2
-# }
-# else {
-# warning(gettextf("subclass %s of class %s is not local and cannot be updated for new inheritance information; consider setClassUnion()",
-# .dQ(what), .dQ(class)),
-# call. = FALSE, domain = NA)
-# next
-# }
-# extension <- extDefs[[what]]
-# if(is.null(extension)) # not possible if the setIs behaved?
-# warning(gettextf("no definition of inheritance from %s to %s, though the relation was implied by the setIs() from %s",
-# .dQ(what), .dQ(def2@className), .dQ(class)),
-# call. = FALSE, domain = NA)
-# else if(is.na(match(class2, names(subDef@contains)))) {
-# subDef@contains[[class2]] <- extension
-# assignClassDef(what, subDef, cwhere, TRUE)
-# }
-# }
-# NULL
-#}
-#
-#.removeSuperclassBackRefs <- function(Class, classDef, classWhere)
-#{
-# if(length(classDef@contains)) {
-# superclasses <- names(classDef@contains)
-# for(what in superclasses) {
-# cdef <- .getClassFromCache(what)
-# ## TODO: handle the case of multiple packages with this class
-# if(is(cdef, "classRepresentation"))
-# .removeSubClass(what, Class, cdef)
-# }
-# }
-# NULL
-#}
-#
-#
-### remove subclass from the list of subclasses of class
-### in the cache and possibly in the attached package environment
-#.removeSubClass <- function(class, subclass, cdef) {
-# if(is.null(cdef)) {}
-# else {
-# newdef <- .deleteSubClass(cdef, subclass)
-# if(!is.null(newdef))
-# .cacheClass(class, newdef, FALSE, cdef@package)
-# ## the class definition in the search list may have been altered
-# ## (e.g., when classes are created in the global environment_
-# pname <- cdef@package
-# if(identical(pname, ".GlobalEnv")) {
-# pos <- 1
-# }
-# else {
-# pname <- paste0("package:", pname)
-# pos <- match(pname, search(), 0)
-# }
-# if(pos) {
-# penv <- as.environment(pname)
-# cmeta <- classMetaName(class)
-# if(exists(cmeta, envir = penv, inherits = FALSE)) {
-# cdefp <- get(cmeta, envir = penv)
-# if(subclass %in% names(cdefp@subclasses)) {
-# newdef <- .deleteSubClass(cdefp, subclass)
-# if(!is.null(newdef)) {
-# ## unfortunately, assignClassDef assigns the subclass info
-# ## even in a locked binding. Would be nice to change that,
-# ## but probably too much would break.
-# if(bindingIsLocked(cmeta, penv))
-# .assignOverBinding(cmeta, newdef, penv, FALSE)
-# else
-# assign(cmeta, newdef, envir = penv)
-# }
-# }
-# }
-# }
-# }
-# sig <- signature(from=subclass, to=class)
-# if(existsMethod("coerce", sig))
-# .removeCachedMethod("coerce", sig)
-# if(existsMethod("coerce<-", sig))
-# .removeCachedMethod("coerce<-", sig)
-#}
-#
-#.deleteSubClass <- function(cdef, subclass) {
-# subclasses <- cdef@subclasses
-# ii <- match(subclass, names(subclasses), 0)
-# ## the subclass may not be there, e.g., if that class has been
-# ## unloaded.
-# if(ii > 0) {
-# cdef@subclasses <- subclasses[-ii]
-# cdef
-# }
-# else
-# NULL
-#}
-#
-### remove superclass from definition of class in the cache & in environments
-### on search list
-#.removeSuperClass <- function(class, superclass) {
-# cdef <- .getClassFromCache(class, where)
-# if(is.null(cdef)) {}
-# else {
-# newdef <- .deleteSuperClass(cdef, superclass)
-# if(!is.null(newdef))
-# .cacheClass(class, newdef, FALSE, where)
-# }
-# sig <- signature(from=class, to=superclass)
-# if(existsMethod("coerce", sig))
-# .removeCachedMethod("coerce", sig)
-# if(existsMethod("coerce<-", sig))
-# .removeCachedMethod("coerce<-", sig)
-# evv <- findClass(class, .GlobalEnv) # what about hidden classes? how to find them?
-# mname <- classMetaName(class)
-# for(where in evv) {
-# if(exists(mname, envir = where, inherits = FALSE)) {
-# cdef <- get(mname, envir = where)
-# newdef <- .deleteSuperClass(cdef, superclass)
-# if(!is.null(newdef)) {
-# assignClassDef(class, newdef, where, TRUE)
-# ## message("deleted ",superclass, " from ",class, "in environment")
-# }
-# }
-# }
-# NULL
-#}
-#
-#.deleteSuperClass <- function(cdef, superclass) {
-# superclasses <- cdef@contains
-# ii <- match(superclass, names(superclasses), 0)
-# if(ii > 0) {
-# cdef@contains <- superclasses[-ii]
-# for(subclass in names(cdef@subclasses))
-# .removeSuperClass(subclass, superclass)
-# cdef
-# }
-# else
-# NULL
-#}
-#
-#classesToAM <- function(classes, includeSubclasses = FALSE,
-# abbreviate = 2) {
-# .mergeMatrices <- function(m1, m2) {
-# if(nrow(m1) == 0)
-# return(m2)
-# dn1 <- dimnames(m1)
-# dn2 <- dimnames(m2)
-# rows <- unique(c(dn1[[1]], dn2[[1]]))
-# columns <- unique(c(dn1[[2]], dn2[[2]]))
-# value <- matrix(0, length(rows), length(columns), dimnames = list(rows, columns))
-# value[dn1[[1]], dn1[[2]] ] <- m1
-# value[dn2[[1]], dn2[[2]] ] <- m2
-# value
-# }
-# if(length(includeSubclasses) == 1)
-# includeSubclasses <- rep.int(includeSubclasses, length(classes))
-# if(!is(includeSubclasses, "logical") || length(includeSubclasses) != length(classes))
-# stop("argument 'includeSubclasses' must be a logical, either one value or a vector of the same length as argument 'classes'")
-# value <- matrix(0,0,0)
-# for(i in seq_along(classes)) {
-# class <- classes[[i]] # to allow for package attribute
-# classDef <- getClass(class) # throws an error if undefined. Make a warning?
-# value <- .mergeMatrices(value, .oneClassToAM(classDef, includeSubclasses[[i]]))
-# }
-# abbr <- match(as.integer(abbreviate), 0:3)-1
-# if(length(abbr) != 1 || is.na(abbr))
-# stop("argument 'abbreviate' must be 0, 1, 2, or 3")
-# if(abbr %% 2)
-# dimnames(value)[[1]] <- base::abbreviate(dimnames(value)[[1]])
-# if(abbr %/% 2)
-# dimnames(value)[[2]] <- base::abbreviate(dimnames(value)[[2]])
-# value
-#}
-#
-#.oneClassToAM <- function(classDef, includeSubclasses = FALSE, short = FALSE) {
-# findEdges <- function(extensions) {
-# superclasses <- names(extensions)
-# edges <- numeric()
-# for(what in superclasses) {
-# whatDef <- getClassDef(what)
-# ifrom <- match(what, nodes)
-# if(is.null(whatDef) || is.na(ifrom))
-# next
-# exts <- whatDef@contains
-# whatedges <- names(exts)
-# ito <- match(whatedges, nodes, 0)
-# for(i in seq_along(exts))
-# if(ito[[i]] >0 && exts[[i]]@distance == 1)
-# edges <- c(edges, ifrom, ito[[i]])
-# }
-# edges
-# }
-# nodes <- c(classDef@className, names(classDef@contains))
-# if(includeSubclasses)
-# nodes <- c(nodes, names(classDef@subclasses))
-# nodes <- unique(nodes)
-# labels <-
-# if(isTRUE(short)) abbreviate(nodes)
-# else if(is.character(short)) {
-# if(length(short) != length(nodes))
-# stop(gettextf("needed the supplied labels vector of length %d, got %d",
-# length(nodes), length(short)), domain = NA)
-# else short
-# } else nodes
-# size <- length(nodes)
-# value <- matrix(0, size, size, dimnames = list(labels, labels))
-# ifrom <- match(classDef@className, nodes) # well, 1, but just for consistency
-# ## the following could use the current fact that direct superclasses come
-# ## first, but the efficiency gain is minor, so we use the findEdges logic
-# extensions <- classDef@contains
-# superclasses <- names(extensions)
-# ito <- match(superclasses, nodes)
-# edges <- numeric()
-# for(i in seq_along(extensions)) {
-# exti <- extensions[[i]]
-# if(exti@distance == 1)
-# edges <- c(edges, ifrom, ito[[i]])
-# }
-# edges <- c(edges, findEdges(classDef@contains))
-# if(includeSubclasses) {
-# edges <- c(edges, findEdges(classDef@subclasses))
-# }
-# edges <- t(matrix(edges, nrow=2))
-# value[edges] <- 1
-# value
-#}
-#
-#.choosePos <- function (thisClass, superclasses, subNames, affected)
-### find if possible a set of superclass relations that gives a consistent
-### ordering and eliminates any duplicates in the affected relations
-### Note that the returned indices are against the index of superclasses
-### If no successful selection is possible, return (one of) the best
-### attempt, and the superclass(es) inconsistently embedded
-#{
-# candidates <- list()
-# allNames <- c(thisClass, superclasses)
-# dups <- unique(superclasses[affected])
-# whichCase <- names(subNames)
-# for(what in dups) {
-# where <- seq_along(allNames)[match( allNames, what,0)>0]
-# ## make a list of all the subsets to remove duplicates
-# whatRemove <- lapply(-seq_along(where), function(x,y) y[x], y=where)
-# if(length(candidates) == 0)
-# candidates <- whatRemove
-# else # all the pairwise combinations with the previous
-# candidates <- outer(candidates, whatRemove,
-# function(x,y)mapply(c,x,y, SIMPLIFY=FALSE))
-# }
-# ## check each way to make the list unique against each superclass extension
-# problems <- function(x,y) any(diff(match(y, x))<0)
-# possibles <- lapply(candidates, function(x, names)names[-x], names=allNames)
-# ## the next could be vectorized, but here we choose instead to exit early.
-# scores <- vector("list", length(possibles))
-# for(i in seq_along(possibles)) {
-# score <- sapply(subNames, problems, x=possibles[[i]])
-# scores[[i]] <- whichCase[score]
-# if(!any(score))
-# return(-candidates[[i]]+1)
-# }
-# # the first min. scoring possibility and its score
-# i <- which.min(sapply(scores, length))
-# list(-candidates[[i]]+1, scores[[i]])
-#}
-#
-#.checkGeneric <- function(what, where) {
-# .checkFun <- function(x) {
-# maybe <- (if(exists(x, where)) {
-# f <- get(x, where)
-# is.function(f)
-# }
-# else
-# FALSE)
-# if(maybe)
-# maybe <- is(f, "genericFunction") ||
-# (length(grep("UseMethod", deparse(f))) > 0) ||
-# is.primitive(f)
-# maybe
-# }
-# sapply(what, .checkFun)
-#}
-#
-#
-#S3forS4Methods <- function(where, checkClasses = character()) {
-# allClasses <- getClasses(where)
-# if(length(checkClasses) > 0)
-# allClasses <- allClasses[match(allClasses, checkClasses, 0) > 0]
-# if(length(allClasses) == 0)
-# return(allClasses)
-# pattern <- paste0("([.]",allClasses, "$)", collapse="|")
-# allObjects <- objects(where, all.names = TRUE)
-# allObjects <- allObjects[-grep("^[.][_][_]", allObjects)] # remove meta data
-# allObjects <- grep(pattern, allObjects, value = TRUE)
-# if(length(allObjects) > 0) {
-# badMethods <- allObjects
-# funs <- sub(pattern, "", badMethods)
-# uniqueFuns <- unique(funs)
-# uniqueFuns <- uniqueFuns[nzchar(uniqueFuns)]
-# possible <- .checkGeneric(uniqueFuns, where)
-# if(!any(possible))
-# return(character())
-# uniqueFuns <- uniqueFuns[possible]
-# badMethods <- badMethods[match(funs, uniqueFuns, 0) > 0]
-# allObjects <- badMethods
-# attr(allObjects, "functions") <- uniqueFuns
-# }
-# allObjects
-#}
-#
-### ## this function warns of S3 methods for S4 classes, but only once per package
-### ## per session.
-### .checkS3forS4 <- function(method) {
-### envir <- environment(method)
-### pkg <- getPackageName(envir)
-### if(!nzchar(pkg)) pkg <- getPackageName(parent.env(pkg)) #? if generic function
-### if(!nzchar(pkg)) pkg <- format(envir)
-### if(!exists(".WarnedS3forS4", .GlobalEnv, inherits = FALSE))
-### assign(".WarnedS3forS4", character(), envir = .GlobalEnv)
-### if(is.na(match(pkg, .WarnedS3forS4))) {
-### methods <- S3forS4Methods(envir)
-### .WarnedS3forS4 <<- c(.WarnedS3forS4, pkg)
-### if(length(methods) > 0) {
-### warning("S3 methods written for S4 classes will fail inheritance!\nPackage ", pkg, " apparently has ",
-### length(methods), " such methods for the functions ", paste(attr(methods, "functions"), collapse = ", "), "\n\n",
-### "Possible dangerous methods: ", paste(methods, collapse =", "),
-### "\n\n(Warnings generated once per package per session)")
-### }
-### }
-### }
-#
-### a warning when a class is defined that extends classes with S3 methods.
-### .checkS3forClass <- function(className, where, what = className) {
-### badMethods <- S3forS4Methods(where, what)
-### if(length(badMethods) > 0) {
-### msg <- paste0("The apparent methods are ", paste('"',badMethods, '"', collapse = ", "))
-### warning("Some of the superclasses in the definition of class \"",
-### className, "\" have apparent S3 methods.\n\nThese will be hidden by the S3 class that this class contains. (See ?Methods)\n\n", msg)
-### }
-### }
-#
-### a utility to detect mixin classes: meant to be fast for use in
-### initialize methods (cf the "matrix" method in BasicClasses.R)
-#isMixin <- function(classDef) {
-# val <- 0
-# cc <- classDef@contains
-# ## relies on the superclasses in contains slot being ordered by distance
-# for(cl in cc) {
-# if(cl@distance > 1 || val > 1)
-# break
-# val <- val + 1
-# }
-# val > 1
-#}
-#
-#.classDefIsLocked <- function(classDef) {
-# what <- classMetaName(classDef@className)
-# env <- .NamespaceOrEnvironment(classDef@package)
-# is.environment(env) && exists(what, envir = env, inherits = FALSE) &&
-# bindingIsLocked(what, env)
-#}
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RMethodUtils.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RMethodUtils.R
deleted file mode 100644
index 69e4ad3b09de3c47e02db0fd57cead434df70fc0..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/RMethodUtils.R
+++ /dev/null
@@ -1,1945 +0,0 @@
-# File src/library/methods/R/RMethodUtils.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2013 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-## The real version of makeGeneric, to be installed after there are some
-## generic functions to boot the definition (in particular, coerce and coerce<-)
-
-#.makeGeneric <-
-# ## Makes a generic function object corresponding to the given function name.
-# ## and definition.
-# function(f, fdef,
-# fdefault = fdef,
-# group = list(),
-# valueClass = character(),
-# package = getPackageName(environment(fdef)),
-# signature = NULL,
-# genericFunction = NULL,
-# simpleInheritanceOnly = NULL)
-#{
-# checkTrace <- function(fun, what, f) {
-# if(is(fun, "traceable")) {
-# warning(gettextf("the function being used as %s in making a generic function for %s is currently traced; the function used will have tracing removed",
-# what,
-# sQuote(f)),
-# domain = NA)
-# .untracedFunction(fun)
-# }
-# else
-# fun
-# }
-# if(missing(fdef)) {
-# if(missing(fdefault))
-# stop(gettextf("must supply either a generic function or a function as default for %s",
-# sQuote(f)),
-# domain = NA)
-# else if(is.primitive(fdefault)) {
-# return(genericForPrimitive(f))
-# }
-# fdef <- fdefault
-# body(fdef) <- substitute(standardGeneric(NAME), list(NAME = f))
-# environment(fdef) <- .methodsNamespace
-# }
-# ## give the function a new environment, to cache methods later
-# ev <- new.env()
-# parent.env(ev) <- environment(fdef)
-# environment(fdef) <- ev
-# packageSlot(f) <- package
-# assign(".Generic", f, envir = ev)
-# fdef <- checkTrace(fdef)
-# if(length(valueClass))
-# fdef <- .ValidateValueClass(fdef, f, valueClass)
-# group <- .asGroupArgument(group)
-# if(is.null(genericFunction))
-# value <- new("standardGeneric")
-# else if(is(genericFunction, "genericFunction"))
-# value <- genericFunction
-# else
-# stop(gettextf("the %s argument must be NULL or a generic function object; got an object of class %s",
-# sQuote("genericFunction"),
-# dQuote(class(genericFunction))),
-# domain = NA)
-# value@.Data <- fdef
-# value@generic <- f
-# value@group <- group
-# value@valueClass <- valueClass
-# value@package <- package
-# args <- formalArgs(fdef)
-# if(is.null(signature))
-# signature <- args
-# else if(any(is.na(match(signature, args))))
-# stop(sprintf(ngettext(sum(is.na(match(signature, args))),
-# "non-argument found in the signature: %s",
-# "non-arguments found in the signature: %s"),
-# paste(signature[is.na(match(signature, args))], collapse = ", ")),
-# domain = NA)
-# dots <- match("...", signature)
-# if(!is.na(dots)) { # remove "..." unless it is the only element of the signature
-# if(length(signature) > 1L)
-# signature <- signature[-dots]
-# }
-# if(length(signature) == 0L)
-# stop("no suitable arguments to dispatch methods in this function")
-# attr(signature, "simpleOnly") <- simpleInheritanceOnly # usually NULL
-# value@signature <- signature
-# name <- signature[[1L]]
-# if(is.null(fdefault))
-# {} # pre 2.11.0: methods <- MethodsList(name)
-# else {
-# fdefault <- checkTrace(fdefault)
-# if(!identical(formalArgs(fdefault), formalArgs(fdef)) &&
-# !is.primitive(fdefault))
-# stop(sprintf(ngettext(length(fdef),
-# "the formal argument of the generic function for %s (%s) differs from that of the non-generic to be used as the default (%s)",
-# "the formal arguments of the generic function for %s (%s) differ from those of the non-generic to be used as the default (%s)"),
-# paste(formalArgs(fdef), collapse = ", "),
-# paste(formalArgs(fdefault), collapse = ", ")),
-# domain = NA)
-# fdefault <- asMethodDefinition(fdefault, fdef = value)
-# if(is(fdefault, "MethodDefinition"))
-# fdefault@generic <- value@generic
-# ## pre 2.11.0 methods <- MethodsList(name, fdefault)
-# }
-# value@default <- fdefault # pre 2.11.0 methods
-# assign(".Methods", fdefault, envir = ev) ## ? why
-# .setupMethodsTables(value, TRUE)
-# value@skeleton <- generic.skeleton(f, fdef, fdefault)
-# value
-#}
-#
-### stripped down version of asS4 in base (asS4 can't be used until the methods
-### namespace is available -- no longer true)
-#.asS4 <- function (object)
-# asS4(object, TRUE, 0L)
-#
-#.notS4 <- function (object)
-# asS4(object, FALSE, 0L)
-#
-#
-### the bootstrap version: "#----" brackets lines that replace parts of the real version
-#makeGeneric <-
-# function(f, fdef,
-# fdefault = getFunction(f, generic = FALSE, mustFind = FALSE),
-# group = list(), valueClass = character(), package, signature = NULL,
-# genericFunction = NULL, simpleInheritanceOnly = NULL)
-#{
-# ## give the function a new environment, to cache methods later
-# ev <- new.env()
-# parent.env(ev) <- environment(fdef)
-# environment(fdef) <- ev
-# packageSlot(f) <- package
-# assign(".Generic", f, envir = ev)
-# if(length(valueClass))
-# fdef <- .ValidateValueClass(fdef, f, valueClass)
-# group <- .asGroupArgument(group)
-# ###--------
-# value <- .asS4(fdef)
-# if(is.null(genericFunction))
-# class(value) <- .classNameFromMethods("standardGeneric")
-# else
-# class(value) <- class(genericFunction)
-# slot(value, "generic", FALSE) <- f
-# slot(value, "group", FALSE) <- group
-# slot(value, "valueClass", FALSE) <- valueClass
-# slot(value, "package", FALSE) <- package
-# ###--------
-# args <- formalArgs(fdef)
-# if(is.null(signature))
-# signature <- args
-# else if(any(is.na(match(signature, args))))
-# stop(sprintf(ngettext(sum(is.na(match(signature, args))),
-# "non-argument found in the signature: %s",
-# "non-arguments found in the signature: %s"),
-# paste(signature[is.na(match(signature, args))], collapse = ", ")),
-# domain = NA)
-# attr(signature, "simpleOnly") <- simpleInheritanceOnly # usually NULL
-# dots <- match("...", signature)
-# if(!is.na(dots)) ## ... is not currently supported in method signatures
-# signature <- signature[-dots]
-# if(length(signature) == 0L)
-# stop("no suitable arguments to dispatch methods in this function")
-# ###--------
-# slot(value, "signature", FALSE) <- signature
-# ###--------
-# name <- signature[[1L]]
-# if(is.null(fdefault))
-# {}
-# else
-# fdefault <- asMethodDefinition(fdefault, fdef = value)
-# if(is(fdefault, "MethodDefinition"))
-# fdefault@generic <- value@generic
-# ## pre 2.11.0 methods <- MethodsList(name, fdefault)
-# ###--------
-# assign(".Methods", fdefault, envir = ev)
-# slot(value, "default", FALSE) <- fdefault
-# slot(value, "skeleton", FALSE) <- generic.skeleton(f, fdef, fdefault)
-# ###--------
-# value
-#}
-#
-#
-#makeStandardGeneric <-
-# ## a utility function that makes a valid function calling standardGeneric for name f
-# ## Works (more or less) even if the actual definition, fdef, is not a proper function,
-# ## that is, it is a primitive or internal
-# function(f, fdef)
-#{
-# fgen <- fdef
-# body(fgen) <- substitute(standardGeneric(FNAME), list(FNAME=f))
-# ## detect R specials and builtins: these don't provide an argument list
-# if(typeof(fdef) != "closure") {
-# ## Look in a list of pre-defined functions (and also of functions for which
-# ## methods are prohibited)
-# fgen <- genericForPrimitive(f)
-# if(identical(fgen, FALSE))
-# stop(gettextf("special function %s is not permitted to have methods",
-# sQuote(f)),
-# domain = NA)
-# if(is.null(fgen)) {
-# warning(gettextf("special function %s has no known argument list; will assume '(x, ...)'",
-# sQuote(f)),
-# domain = NA)
-# ## unknown
-# fgen <- function(x, ...) {}
-# }
-# else {
-# message(gettextf("making a generic for special function %s",
-# sQuote(f)),
-# domain = NA)
-# setPrimitiveMethods(f, fdef, "reset", fgen, NULL)
-# }
-# ## Note that the body of the function comes from the list. In a few cases ("$"),
-# ## this body is not just a call to standardGeneric
-# }
-# fgen
-#}
-#
-#generic.skeleton <- function(name, fdef, fdefault)
-#{
-# anames <- formalArgs(fdef)
-# skeleton <- lapply(as.list(c(name, anames)), as.name)
-# ## any arguments after "..." have to be named
-# dots <- match("...", anames)
-# if(!is.na(dots) && dots < length(anames)) {
-# anames[1L:dots] <- ""
-# names(skeleton) <- c("", anames)
-# }
-# if(is.null(fdefault)) {
-# fdefault <- fdef
-# body(fdefault) <- substitute(stop(MESSAGE, domain = NA), list(MESSAGE=
-# gettextf("invalid call in method dispatch to '%s' (no default method)", name)))
-# environment(fdefault) <- baseenv()
-# }
-# skeleton[[1L]] <- fdefault
-# as.call(skeleton)
-#}
-#
-#
-#defaultDumpName <-
-# ## the default name to be used for dumping a method.
-# function(generic, signature)
-#{
-# if(missing(signature))
-# paste(generic, "R", sep=".", collapse =".")
-# else
-# paste(generic, paste(signature, collapse ="."), "R", sep=".")
-#}
-#
-#
-#mergeMethods <-
-# ## merge the methods in the second MethodsList object into the first,
-# ## and return the merged result.
-# function(m1, m2, genericLabel = character())
-#{
-# if(length(genericLabel) && is(m2, "MethodsList"))
-# m2 <- .GenericInPrimitiveMethods(m2, genericLabel)
-# if(is.null(m1) || is(m1, "EmptyMethodsList"))
-# return(m2)
-# tmp <- listFromMlist(m2)
-# sigs <- el(tmp, 1)
-# methods <- el(tmp, 2)
-# for(i in seq_along(sigs)) {
-# sigi <- el(sigs, i)
-# if(.noMlists() && !identical(unique(sigi), "ANY"))
-# next
-# args <- names(sigi)
-# m1 <- insertMethod(m1, as.character(sigi), args, el(methods, i), FALSE)
-# }
-# m1
-#}
-#
-#doPrimitiveMethod <-
-# ## do a primitive call to builtin function 'name' the definition and call
-# ## provided, and carried out in the environment 'ev'.
-# ##
-# ## A call to 'doPrimitiveMethod' is used when the actual method is a .Primitive.
-# ## (because primitives don't behave correctly as ordinary functions,
-# ## not having either formal arguments nor a function body).
-# function(name, def, call = sys.call(sys.parent()), ev = sys.frame(sys.parent(2)))
-#{
-# cat("called doPrimitiveMethod\n\n")
-# ## Store a local version of function 'name' back where the current version was
-# ## called. Restore the previous state there on exit, either removing or re-assigning.
-# if(exists(name, envir=ev, inherits=FALSE)) {
-# prev <- get(name, envir=ev)
-# on.exit(assign(name, prev, envir = ev))
-# }
-# else
-# on.exit(rm(list=name, envir=ev))
-# assign(name, def, envir = ev)
-# eval(call, ev)
-#}
-#
-#.renderSignature <- function(f, signature)
-#{
-# nm <- names(signature)
-# nm[nzchar(nm)] <- paste0(nm[nzchar(nm)], "=")
-# msig <- paste0(nm, '"', as.vector(signature), '"')
-# msig <- paste(msig, collapse = ",")
-# gettextf("in method for %s with signature %s: ", sQuote(f), sQuote(msig))
-#}
-#
-#conformMethod <- function(signature, mnames, fnames,
-# f = "<unspecified>", fdef, method)
-#{
-# sig0 <- signature
-# fsig <- fdef@signature
-# if(is.na(match("...", mnames)) && !is.na(match("...", fnames)))
-# fnames <- fnames[-match("...", fnames)]
-# imf <- match(fnames, mnames)
-# omitted <- is.na(imf)
-# if(is.unsorted(imf[!omitted]))
-# stop(.renderSignature(f, signature),
-# "formal arguments in method and generic do not appear in the same order",
-# call. = FALSE)
-# if(!any(omitted)) ## i.e. mnames contains all fnames
-# return(signature)
-# sigNames <- names(signature)
-# omittedSig <- sigNames %in% fnames[omitted] # names in signature & generic but not in method defn
-# ### FIXME: the test below is too broad, with all.names(). Would be nice to have a test
-# ### for something like assigning to one of the omitted arguments.
-# ## missingFnames <- fnames[omitted]
-# ## foundNames <- missingFnames %in% all.names(body(method), unique = TRUE)
-# ## if(any(foundNames))
-# ## warning(gettextf("%s function arguments omitted from method arguments, (%s), were found in method definition",
-# ## label, paste(missingFnames[foundNames], collapse = ", ")),
-# ## domain = NA)
-# if(!any(omittedSig))
-# return(signature)
-# if(any(is.na(match(signature[omittedSig], c("ANY", "missing"))))) {
-# bad <- omittedSig & is.na(match(signature[omittedSig], c("ANY", "missing")))
-# bad2 <- paste0(fnames[bad], " = \"", signature[bad], "\"", collapse = ", ")
-# stop(.renderSignature(f, sig0),
-# gettextf("formal arguments (%s) omitted in the method definition cannot be in the signature", bad2),
-# call. = TRUE, domain = NA)
-# }
-# else if(!all(signature[omittedSig] == "missing")) {
-# omittedSig <- omittedSig && (signature[omittedSig] != "missing")
-# .message("Note: ", .renderSignature(f, sig0),
-# gettextf("expanding the signature to include omitted arguments in definition: %s",
-# paste(sigNames[omittedSig], "= \"missing\"",collapse = ", ")))
-# omittedSig <- seq_along(omittedSig)[omittedSig] # logical index will extend signature!
-# signature[omittedSig] <- "missing"
-# }
-# ## remove trailing "ANY"'s
-# n <- length(signature)
-# while(.identC(signature[[n]], "ANY"))
-# n <- n - 1L
-# length(signature) <- n
-# length(fsig) <- n
-# names(signature) <- fsig
-# signature
-#}
-#
-#rematchDefinition <- function(definition, generic, mnames, fnames, signature)
-#{
-# added <- any(is.na(match(mnames, fnames)))
-# keepsDots <- !is.na(match("...", mnames))
-# if(!added && keepsDots) {
-# ## the formal args of the method must be identical to generic
-# formals(definition, envir = environment(definition)) <- formals(generic)
-# return(definition)
-# }
-# dotsPos <- match("...", fnames)
-# if(added && is.na(dotsPos))
-# stop(gettextf("methods can add arguments to the generic %s only if '...' is an argument to the generic", sQuote(generic@generic)),
-# call. = TRUE)
-# ## pass down all the names in common between method & generic,
-# ## plus "..." even if the method doesn't have it. But NOT any
-# ## arguments having class "missing" implicitly (see conformMethod),
-# ## i.e., are not among 'mnames':
-# useNames <- !is.na(imf <- match(fnames, mnames)) | fnames == "..."
-# newCall <- lapply(c(".local", fnames[useNames]), as.name)
-#
-# ## Should not be needed, if conformMethod() has already been called:
-# if(is.unsorted(imf[!is.na(imf)]))
-# stop(.renderSignature(generic@generic, signature),
-# "formal arguments in method and generic do not appear in the same order",
-# call. = FALSE)
-#
-# ## leave newCall as a list while checking the trailing args
-# if(keepsDots && dotsPos < length(fnames)) {
-# ## Trailing arguments are required to match. This is a little
-# ## stronger than necessary, but this is a dicey case, because
-# ## the argument-matching may not be consistent otherwise (in
-# ## the generic, such arguments have to be supplied by name).
-# ## The important special case is replacement methods, where
-# ## value is the last argument.
-#
-# ntrail <- length(fnames) - dotsPos
-# trailingArgs <- fnames[seq.int(to = length(fnames), length.out = ntrail)]
-# if(!identical( mnames[seq.int(to = length(mnames), length.out = ntrail)],
-# trailingArgs))
-# stop(gettextf("arguments (%s) after '...' in the generic must appear in the method, in the same place at the end of the argument list",
-# paste(trailingArgs, collapse=", ")),
-# call. = TRUE, domain = NA)
-# newCallNames <- character(length(newCall))
-# newCallNames[seq.int(to = length(newCallNames), length.out = ntrail)] <-
-# trailingArgs
-# names(newCall) <- newCallNames
-# }
-# newCall <- as.call(newCall)
-# newBody <- substitute({.local <- DEF; NEWCALL},
-# list(DEF = definition, NEWCALL = newCall))
-# generic <- .copyMethodDefaults(generic, definition)
-# body(generic, envir = environment(definition)) <- newBody
-# generic
-#}
-#
-#unRematchDefinition <- function(definition)
-#{
-# ## undo the effects of rematchDefiniition, if it was used.
-# ## Has the obvious disadvantage of depending on the implementation.
-# ## If we considered the rematching part of the API, a cleaner solution
-# ## would be to include the "as given to setMethod" definition as a slot
-# bdy <- body(definition)
-# if(.identC(class(bdy),"{") && length(bdy) > 1L) {
-# bdy <- bdy[[2L]]
-# if(.identC(class(bdy), "<-") &&
-# identical(bdy[[2L]], as.name(".local")))
-# definition <- bdy[[3L]]
-# }
-# definition
-#}
-#
-#getGeneric <-
-# ## return the definition of the function named f as a generic.
-# ##
-# ## If there is no definition, throws an error or returns
-# ## NULL according to the value of mustFind.
-# function(f, mustFind = FALSE, where, package = "")
-#{
-# if(is.function(f)) {
-# if(is(f, "genericFunction"))
-# return(f)
-# else if(is.primitive(f))
-# return(genericForPrimitive(.primname(f)))
-# else
-# stop("argument 'f' must be a string, generic function, or primitive: got an ordinary function")
-# }
-# value <- if(missing(where))
-# .getGeneric(f, , package) else
-# .getGeneric(f, where, package)
-# if(is.null(value) && exists(f, envir = baseenv(), inherits = FALSE)) {
-# ## check for primitives
-# baseDef <- get(f, envir = baseenv())
-# if(is.primitive(baseDef)) {
-# value <- genericForPrimitive(f)
-# if(!is.function(value) && mustFind)
-# stop(gettextf("methods cannot be defined for the primitive function %s",
-# sQuote(f)), domain = NA)
-# if(is(value, "genericFunction"))
-# value <- .cacheGeneric(f, value)
-# }
-# }
-# if(is.function(value))
-# value
-# else {
-# if(nzchar(package) && is.na(match(package, c("methods", "base")))) {
-# ## try to load package, or attach it if necessary
-# ev <- tryCatch(loadNamespace(package), error = function(e)e)
-# if(is(ev, "error") &&
-# require(package, character.only =TRUE))
-# ev <- as.environment(paste("package",package,sep=":"))
-# if(is.environment(ev))
-# value <- .getGeneric(f, ev, package)
-# }
-# if(is.function(value))
-# value
-# else if(mustFind)
-# ## the C code will have thrown an error if f is not a single string
-# stop(gettextf("no generic function found for %s",
-# sQuote(f)),
-# domain = NA)
-# else
-# NULL
-# }
-#}
-#
-### low-level version
-#.getGeneric <- function(f, where = .GlobalEnv, # default only for C search
-# package = "")
-#{
-# ## do not search the cache if getGeneric() was called with explicit where=
-# if(missing(where))
-# value <- .getGenericFromCache(f, where, package)
-# else
-# value <- NULL
-# if(is.null(value)) {
-# if(is.character(f) && f %in% "as.double") f <- "as.numeric"
-# if(is.character(f) && !nzchar(f)) {
-# message("Empty function name in .getGeneric")
-# dput(sys.calls())
-# }
-# value <- .Call(C_R_getGeneric, f, FALSE, as.environment(where), package)
-# ## cache public generics (usually these will have been cached already
-# ## and we get to this code for non-exported generics)
-# if(!is.null(value) && exists(f, .GlobalEnv) &&
-# identical(get(f, .GlobalEnv), value))
-# .cacheGeneric(f, value)
-# }
-# ## if(is.null(value) && nzchar(package) && !identical(package, "base")) {
-# ## env <- .requirePackage(package, FALSE)
-# ## if(is.environment(env))
-# ## value <- .Call("R_getGeneric", f, FALSE, env, package,
-# ## PACKAGE = "methods")
-# ## }
-# value
-#}
-#
-### cache and retrieve generic functions. If the same generic name
-### appears for multiple packages, a named list of the generics is cached.
-#.genericTable <- new.env(TRUE, baseenv())
-#
-#.implicitTable <- new.env(TRUE, baseenv())
-#
-#.cacheGeneric <- function(name, def)
-# .cacheGenericTable(name, def, .genericTable)
-#
-#.cacheImplicitGeneric <- function(name, def)
-# .cacheGenericTable(name, def, .implicitTable)
-#
-#.cacheGenericTable <- function(name, def, table)
-#{
-# fdef <- def
-# if(exists(name, envir = table, inherits = FALSE)) {
-# newpkg <- def@package
-# prev <- get(name, envir = table)
-# if(is.function(prev)) {
-# if(identical(prev, def))
-# return(fdef)
-# ## the following makes the cached version != package
-# ## fdef <- def <- .makeGenericForCache(def)
-# pkg <- prev@package
-# if(identical(pkg, newpkg)) { # redefinition
-# assign(name, def, envir = table)
-# return(fdef)
-# }
-# prev <- list(prev) # start a per-package list
-# names(prev) <- pkg
-# }
-# i <- match(newpkg, names(prev))
-# if(is.na(i))
-# prev[[newpkg]] <- def # or, .makeGenericForCache(def) as above
-# else if(identical(def, prev[[i]]))
-# return(fdef)
-# else
-# prev[[i]] <- def # or, .makeGenericForCache(def) as above
-# def <- prev
-# }
-#
-# .getMethodsTable(fdef) # force initialization
-# assign(name, def, envir = table)
-# fdef
-#}
-#
-#.uncacheGeneric <- function(name, def)
-# .uncacheGenericTable(name, def, .genericTable)
-#
-#.uncacheImplicitGeneric <- function(name, def)
-# .uncacheGenericTable(name, def, .implicitTable)
-#
-#.uncacheGenericTable <- function(name, def, table)
-#{
-# if(exists(name, envir = table, inherits = FALSE)) {
-# newpkg <- def@package
-# prev <- get(name, envir = table)
-# if(is.function(prev)) # we might worry if prev not identical
-# return(remove(list = name, envir = table))
-# i <- match(newpkg, names(prev))
-# if(!is.na(i))
-# prev[[i]] <- NULL
-# else # we might warn about unchaching more than once
-# return()
-# if(length(prev) == 0L)
-# return(remove(list = name, envir = table))
-# else if(length(prev) == 1L)
-# prev <- prev[[1L]]
-# assign(name, prev, envir = table)
-# }
-#}
-#
-#.getGenericFromCache <- function(name, where, pkg = "")
-# .getGenericFromCacheTable(name,where, pkg, .genericTable)
-#
-#.getImplicitGenericFromCache <- function(name, where, pkg = "")
-# .getGenericFromCacheTable(name,where, pkg, .implicitTable)
-#
-#.getGenericFromCacheTable <- function(name, where, pkg = "", table)
-#{
-# if(exists(name, envir = table, inherits = FALSE)) {
-# value <- get(name, envir = table)
-# if(is.list(value)) { # multiple generics with this name
-# ## force a check of package name, even if argument is ""
-# if(!nzchar(pkg)) {
-# if(is.character(where))
-# pkg <- where
-# else {
-# pkg <- attr(name, "package")
-# if(is.null(pkg))
-# pkg <- getPackageName(where, FALSE)
-# if(identical(pkg, ".GlobalEnv"))
-# pkg <- ""
-# }
-# }
-# pkgs <- names(value)
-# i <- match(pkg, pkgs, 0L)
-# if(i > 0L)
-# return(value[[i]])
-# i <- match("methods", pkgs, 0L)
-# if(i > 0L)
-# return(value[[i]])
-# i <- match("base", pkgs, 0L)
-# if(i > 0L)
-# return(value[[i]])
-# else
-# return(NULL)
-# }
-# else if(nzchar(pkg) && !identical(pkg, value@package))
-# NULL
-# else
-# value
-# }
-# else
-# NULL
-#}
-#
-#.genericOrImplicit <- function(name, pkg, env)
-#{
-# fdef <- .getGenericFromCache(name, env, pkg)
-# if(is.null(fdef)) {
-# penv <- tryCatch(getNamespace(pkg), error = function(e)e)
-# if(!isNamespace(penv)) { # no namespace--should be rare!
-# pname <- paste0("package:", pkg)
-# penv <- if(pname %in% search()) as.environment(pname) else env
-# }
-# fdef <- getFunction(name, TRUE, FALSE, penv)
-# if(!is(fdef, "genericFunction")) {
-# if(is.primitive(fdef))
-# fdef <- genericForPrimitive(name, penv)
-# else
-# fdef <- implicitGeneric(name, penv)
-# }
-# }
-# fdef
-#}
-#
-#
-### copy the environments in the generic function so later merging into
-### the cached generic will not modify the generic in the package.
-### NOT CURRENTLY USED: see comments in .getGeneric()
-#.makeGenericForCache <- function(fdef)
-#{
-# value <- fdef
-# ev <- environment(fdef)
-# environment(value) <- newEv <- new.env(TRUE, parent.env(ev))
-# for(what in objects(ev, all.names=TRUE)) {
-# obj <- get(what, envir = ev)
-# if(is.environment(obj))
-# obj <- .copyEnv(obj)
-# assign(what, obj, envir = newEv)
-# }
-# value
-#}
-#
-#.copyEnv <- function(env)
-#{
-# value <- new.env(TRUE, parent.env(env))
-# for(what in objects(env, all.names = TRUE))
-# assign(what, get(what, envir = env), envir = value)
-# value
-#}
-#
-#getGroup <-
-# ## return the groups to which this generic belongs. If 'recursive=TRUE', also all the
-# ## group(s) of these groups.
-# function(fdef, recursive = FALSE, where = topenv(parent.frame()))
-#{
-# if(is.character(fdef))
-# fdef <- getGeneric(fdef, where = where)
-# if(is(fdef, "genericFunction"))
-# group <- fdef@group
-# else
-# group <- list()
-# if(recursive && length(group)) {
-# allGroups <- group
-# for(gp in group) {
-# fgp <- getGeneric(gp, where = where)
-# if(is(fgp, "groupGenericFunction"))
-# allGroups <- c(allGroups, Recall(fgp, TRUE, where))
-# }
-# if(length(allGroups) > 1L) {
-# ids <- sapply(allGroups, function(x) {
-# pkg <- packageSlot(x)
-# if(is.null(pkg)) x
-# else paste(x, pkg, sep=":")
-# })
-# allGroups <- allGroups[!duplicated(ids)]
-# }
-# allGroups
-# }
-# else
-# group
-#}
-#
-#getMethodsMetaData <- function(f, where = topenv(parent.frame()))
-#{
-# fdef <- getGeneric(f, where = where)
-# if(is.null(fdef))
-# return(NULL)
-# if(.noMlists()) {
-# warning(sprintf("Methods list objects are not maintained in this version of R: request for function %s may return incorrect information",
-# sQuote(fdef@generic)),
-# domain = NA)
-# }
-# mname <- methodsPackageMetaName("M",fdef@generic, fdef@package)
-# if (exists(mname, where = where, inherits = missing(where)))
-# get(mname, where)
-# else if(missing(where))
-# .makeMlistFromTable(fdef)
-# else
-# .makeMlistFromTable(fdef, where)
-#}
-#
-#assignMethodsMetaData <-
-# ## assign value to be the methods metadata for generic f on database where.
-# ## as of R 2.7.0 the mlist metadata is deprecated.
-# ## If value is not a MethodsList, only turns on primitives & groups
-# function(f, value, fdef, where, deflt)
-#{
-# where <- as.environment(where)
-# if(is(value, "MethodsList")) {
-# mname <- methodsPackageMetaName("M",fdef@generic, fdef@package)
-# if(exists(mname, envir = where, inherits = FALSE) &&
-# bindingIsLocked(mname, where))
-# {} # may be called from trace() with locked binding; ignore
-# else
-# assign(mname, value, where)
-# }
-# if(is.primitive(deflt))
-# setPrimitiveMethods(f, deflt, "reset", fdef, NULL)
-# if(is(fdef, "groupGenericFunction")) # reset or turn on members of group
-# cacheGenericsMetaData(f, fdef, where = where, package = fdef@package)
-#}
-#
-#
-### utility for getGenerics to return package(s)
-#.packageForGeneric <- function(object)
-#{
-# if(is.list(object)) # a list of objects
-# lapply(object, .packageForGeneric)
-# else if(is(object, "genericFunction"))
-# object@package
-# else ## ?? possibly a primitive
-# "base"
-#}
-#
-#getGenerics <- function(where, searchForm = FALSE)
-#{
-# if(missing(where)) {
-# ## all the packages cached ==? all packages with methods
-# ## globally visible. Assertion based on cacheMetaData + setMethod
-# fnames <- as.list(objects(.genericTable, all.names=TRUE))
-# packages <- vector("list", length(fnames))
-# for(i in seq_along(fnames)) {
-# obj <- get(fnames[[i]], envir = .genericTable)
-# if(is.list(obj))
-# fnames[[i]] <- names(obj)
-# packages[[i]] <- .packageForGeneric(obj)
-# }
-# new("ObjectsWithPackage", unlist(fnames), package=unlist(packages))
-# }
-# else {
-# if(is.environment(where)) where <- list(where)
-# these <- character()
-# for(i in where)
-# these <- c(these, objects(i, all.names=TRUE))
-# metaNameUndo(unique(these), prefix = "T", searchForm = searchForm)
-# }
-#}
-#
-### Find the pattern for methods lists or tables
-### Currently driven by mlists, but eventually these will go away
-### in favor of tables.
-#
-### always returns a compatible list, with an option of prefix
-#.getGenerics <- function(where, trim = TRUE)
-#{
-# if(missing(where)) where <- .envSearch(topenv(parent.frame()))
-# else if(is.environment(where)) where <- list(where)
-# these <- character()
-# for(i in where) these <- c(these, objects(i, all.names=TRUE))
-# these <- allThese <- unique(these)
-# these <- these[substr(these, 1L, 6L) == ".__T__"]
-# if(length(these) == 0L)
-# return(character())
-# funNames <- gsub(".__T__(.*):([^:]+)", "\\1", these)
-# if(length(funNames) == 0L &&
-# length(these[substr(these, 1L, 6L) == ".__M__"]))
-# warning(sprintf("package %s seems to have out-of-date methods; need to reinstall from source",
-# sQuote(getPackageName(where[[1L]]))))
-# packageNames <- gsub(".__T__(.*):([^:]+(.*))", "\\2", these)
-# attr(funNames, "package") <- packageNames
-# ## Would prefer following, but may be trouble bootstrapping methods
-# ## funNames <- new("ObjectsWithPackage", funNames, package = packageNames)
-# if(identical(trim, TRUE))
-# funNames
-# else {
-# if(identical(trim, FALSE))
-# these
-# else
-# gsub(".__T__", as.character(trim), these)
-# }
-#}
-#
-cacheMetaData <-
- function(where, attach = TRUE, searchWhere = as.environment(where),
- doCheck = TRUE)
-{
-}
-# ## a collection of actions performed on attach or detach
-# ## to update class and method information.
-# pkg <- getPackageName(where)
-# classes <- getClasses(where)
-# for(cl in classes) {
-# cldef <- (if(attach) get(classMetaName(cl), where) # NOT getClassDef, it will use cache
-# else getClassDef(cl, searchWhere))
-# if(is(cldef, "classRepresentation")) {
-# if(attach) {
-# .cacheClass(cl, cldef, is(cldef, "ClassUnionRepresentation"), where)
-# }
-# else if(identical(cldef@package, pkg)) {
-# .uncacheClass(cl, cldef)
-# .removeSuperclassBackRefs(cl, cldef, searchWhere)
-# }
-# }
-# }
-# generics <- .getGenerics(where)
-# packages <- attr(generics, "package")
-# if(length(packages) < length(generics))
-# packages <- rep(packages, length.out = length(generics))
-# if(attach && exists(".requireCachedGenerics", where, inherits = FALSE)) {
-# others <- get(".requireCachedGenerics", where)
-# generics <- c(generics, others)
-# packages <- c(packages, attr(others, "package"))
-# }
-# ## check for duplicates
-# dups <- duplicated(generics) & duplicated(packages)
-# generics <- generics[!dups]
-# for(i in seq_along(generics)) {
-# f <- generics[[i]]
-# fpkg <- packages[[i]]
-# if(!identical(fpkg, pkg) && doCheck) {
-# if(attach) {
-# env <- as.environment(where)
-# ## All instances of this generic in different attached packages must
-# ## agree with the cached version of the generic for consistent
-# ## method selection.
-# if(exists(f, envir = env, inherits = FALSE)) {
-# def <- get(f, envir = env)
-# fdef <- .genericOrImplicit(f, fpkg, env)
-# if(is.function(def)) {
-# ## exclude a non-function of the same name as a primitive with methods (!)
-# if(identical(environment(def), environment(fdef)))
-# next # the methods are identical
-# else if( is(fdef, "genericFunction")) {
-# .assignOverBinding(f, fdef, env, FALSE)
-# }
-# } # else, go ahead to update primitive methods
-# }
-# else # either imported generic or a primitive
-# fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
-# }
-# else
-# fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
-# }
-# else
-# fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
-# if(!is(fdef, "genericFunction"))
-# next ## silently ignores all generics not visible from searchWhere
-# if(attach)
-# .cacheGeneric(f, fdef)
-# else
-# .uncacheGeneric(f, fdef)
-# methods <- .updateMethodsInTable(fdef, where, attach)
-# cacheGenericsMetaData(f, fdef, attach, where, fdef@package, methods)
-# }
-# .doLoadActions(where, attach)
-# invisible(NULL) ## as some people call this at the end of functions
-#}
-#
-#
-#cacheGenericsMetaData <- function(f, fdef, attach = TRUE,
-# where = topenv(parent.frame()),
-# package, methods)
-#{
-# if(!is(fdef, "genericFunction")) {
-# warning(gettextf("no methods found for %s; cacheGenericsMetaData() will have no effect",
-# sQuote(f)),
-# domain = NA)
-# return(FALSE)
-# }
-# if(missing(package))
-# package <- fdef@package
-# ### Assertion: methods argument unused except for primitives
-# ### and then only for the old non-table case.
-# deflt <- finalDefaultMethod(fdef@default) #only to detect primitives
-# if(is.primitive(deflt)) {
-# if(missing(methods)) ## "reset"
-# setPrimitiveMethods(f, deflt, "reset", fdef, NULL)
-# else ## "set"
-# setPrimitiveMethods(f, deflt, "set", fdef, methods)
-# }
-# else if(isGroup(f, fdef = fdef)) {
-# members <- fdef@groupMembers
-# ## do the computations for the members as well; important if the
-# ## members are primitive functions.
-# for(ff in members) {
-# ffdef <- getGeneric(ff, where = where)
-# if(is(ffdef, "genericFunction"))
-# Recall(ff, ffdef, attach, where,
-# methods = .getMethodsTable(ffdef))
-# }
-# }
-# TRUE
-#}
-#
-#setPrimitiveMethods <-
-# function(f, fdef, code, generic, mlist = get(".Methods", envir = environment(generic)))
-# .Call(C_R_M_setPrimitiveMethods, f, fdef, code, generic, mlist)
-#
-#### utility to turn ALL primitive methods on or off (to avoid possible inf. recursion)
-#.allowPrimitiveMethods <-
-# function(onOff) {
-# if(onOff) code <- "SET"
-# else code <- "CLEAR"
-# .Call(C_R_M_setPrimitiveMethods, "", NULL, code, NULL, NULL)
-#}
-#
-#
-#findUnique <- function(what, message, where = topenv(parent.frame()))
-#{
-# where <- .findAll(what, where = where)
-# if(length(where) > 1L) {
-# if(missing(message))
-# message <- sQuote(what)
-# if(is.list(where))
-# where <- unlist(where)
-# if(is.numeric(where))
-# where <- search()[where]
-# warning(message,
-# sprintf(" found on: %s; using the first one",
-# paste(sQuote(where), collapse = ", ")),
-# domain = NA)
-# where <- where[1L]
-# }
-# where
-#}
-#
-#MethodAddCoerce <- function(method, argName, thisClass, methodClass)
-#{
-# if(.identC(thisClass, methodClass))
-# return(method)
-# ext <- possibleExtends(thisClass, methodClass)
-# ## if a non-simple coerce is required to get to the target class for
-# ## dispatch, insert it in the method.
-# if(is.logical(ext) || ext@simple)
-# return(method)
-# methodInsert <- function(method, addExpr) {
-# if(is.function(method)) {
-# newBody <- substitute({firstExpr; secondExpr},
-# list(firstExpr = addExpr,
-# secondExpr = body(method)))
-# body(method, envir = environment(method)) <- newBody
-# }
-# else if(is(method, "MethodsList")) {
-# methods <- method@allMethods
-# for(i in seq_along(methods))
-# methods[[i]] <- Recall(methods[[i]], addExpr)
-# method@allMethods <- methods
-# }
-# method
-# }
-# addExpr <- substitute(XXX <- as(XXX, CLASS),
-# list(XXX = argName, CLASS = methodClass))
-# methodInsert(method, addExpr)
-#}
-#
-#missingArg <- function(symbol, envir = parent.frame(), eval = FALSE)
-# .Call(C_R_missingArg, if(eval) symbol else substitute(symbol), envir)
-#
-#balanceMethodsList <- function(mlist, args, check = TRUE)
-#{
-# moreArgs <- args[-1L]
-# if(length(moreArgs) == 0L)
-# return(mlist)
-# methods <- mlist@methods
-# if(check && length(methods)) {
-# ## check whether the current depth is enough (i.e.,
-# ## whether a method with this no. of args or more was set before
-# depth <- 0
-# el <- methods[[1L]]
-# while(is(el, "MethodsList")) {
-# mm <- el@methods
-# if(length(mm) == 0L)
-# break
-# depth <- depth+1L
-# el <- mm[[1L]]
-# }
-# if(depth >= length(args))
-# ## already balanced to this length: An assertion
-# ## relying on balance having been used consistently,
-# ## which in turn relies on setMethod being called to
-# ## add methods. If you roll your own, tough luck!
-# return(mlist)
-# }
-# for(i in seq_along(methods)) {
-# el <- methods[[i]]
-# if(is(el, "MethodsList"))
-# el <- Recall(el, moreArgs, FALSE)
-# else {
-# if(is(el, "MethodDefinition")) {
-# el@target[moreArgs] <- "ANY"
-# el@defined[moreArgs] <- "ANY"
-# }
-# for(what in rev(moreArgs))
-# el <- new("MethodsList", argument = as.name(what),
-# methods = list(ANY = el))
-# }
-# methods[[i]] <- el
-# }
-# mlist@methods <- methods
-# mlist
-#}
-#
-#
-#sigToEnv <- function(signature, generic)
-#{
-# genericSig <- generic@signature
-# package <- packageSlot(signature)
-# if(is.null(package))
-# parent <- environment(generic)
-# else
-# parent <- .requirePackage(package)
-# value <- new.env(parent = parent)
-# classes <- as.character(signature)
-# args <- names(signature)
-# for(i in seq_along(args))
-# assign(args[[i]], classes[[i]], envir = value)
-# ## missing args in signature have class "ANY"
-# if(length(args) < length(genericSig))
-# for(other in genericSig[is.na(match(genericSig, args))])
-# assign(other, "ANY", envir = value)
-# value
-#}
-#
-#methodSignatureMatrix <- function(object, sigSlots = c("target", "defined"))
-#{
-# if(length(sigSlots)) {
-# allSlots <- lapply(sigSlots, slot, object = object)
-# mm <- unlist(allSlots)
-# mm <- matrix(mm, nrow = length(allSlots), byrow = TRUE)
-# dimnames(mm) <- list(sigSlots, names(allSlots[[1L]]))
-# mm
-# }
-# else matrix(character(), 0L, 0L)
-#}
-#
-#.valueClassTest <- function(object, classes, fname)
-#{
-# if(length(classes)) {
-# for(Cl in classes)
-# if(is(object, Cl)) return(object)
-# stop(gettextf("invalid value from generic function %s, class %s, expected %s",
-# sQuote(fname),
-# dQuote(class(object)),
-# paste(dQuote(classes), collapse = " or ")),
-# domain = NA)
-# }
-# ## empty test is allowed
-# object
-#}
-#
-#
-#.getOrMakeMethodsList <- function(f, where, genericFun)
-#{
-# allMethods <- getMethodsMetaData(f, where = where)
-# if(is.null(allMethods)) {
-# argName <- genericFun@signature[[1L]]
-# allMethods <- new("MethodsList", argument = as.name(argName))
-## other <- getMethodsMetaData(f)
-## if(is.null(other))
-## ## this utility is called AFTER ensuring the existence of a generic for f
-## ## Therefore, the case below can only happen for a primitive for which
-## ## no methods currently are attached. Make the primitive the default
-## deflt <- getFunction(f, generic = FALSE, mustFind = FALSE)
-## else
-## ## inherit the default method, if any
-## deflt <- finalDefaultMethod(other)
-## if(!is.null(deflt))
-## allMethods <- insertMethod(allMethods, "ANY", argName, deflt)
-# }
-# allMethods
-#}
-#
-#.makeCallString <- function(def, name = substitute(def), args = formalArgs(def))
-#{
-# if(is.character(def)) {
-# if(missing(name))
-# name <- def
-# def <- getFunction(def)
-# }
-# if(is(def, "function"))
-# paste0(name, "(", paste(args, collapse=", "), ")")
-# else
-# ""
-#}
-#
-#.ValidateValueClass <- function(fdef, name, valueClass)
-#{
-# ## include tests for value
-# fbody <- body(fdef)
-# body(fdef, envir = environment(fdef)) <-
-# substitute(.valueClassTest(EXPR, VALUECLASS, FNAME),
-# list(EXPR = fbody, VALUECLASS = valueClass, FNAME = name))
-# fdef
-#}
-#
-### interpret the group= argument to makeGeneric, allowing for char. argument
-### and "" for compatibility.
-### TO DO: make it possible for this argument to be a group generic function
-### (it may in fact work now).
-#.asGroupArgument <- function(group)
-#{
-# if(is.character(group)) {
-# if(identical(group, ""))
-# list()
-# else
-# as.list(group) ## should we allow c(group, package) ?
-# }
-# else
-# group
-#}
-#
-#metaNameUndo <- function(strings, prefix, searchForm = FALSE)
-#{
-# pattern <- methodsPackageMetaName(prefix, "")
-# n <- nchar(pattern, "c")
-# matched <- substr(strings, 1L, n) == pattern
-# value <- substring(strings[matched], n+1L)
-# pkg <- sub("^[^:]*", "", value) # will be "" if no : in the name
-# if(searchForm) {
-# global <- grep(".GlobalEnv", value)
-# if(length(global)) {
-# pkg[-global] <- paste0("package", pkg[-global])
-# pkg[global] <- substring(pkg[global], 2L)
-# }
-# }
-# else
-# pkg <- substring(pkg, 2L)
-# value <- sub(":.*","", value)
-# new("ObjectsWithPackage", value, package = pkg)
-#}
-#
-#.recursiveCallTest <- function(x, fname)
-#{
-# if(is(x, "call")) {
-# if(identical(x[[1L]], quote(standardGeneric))) {
-# if(!identical(x[[2L]], fname))
-# warning(gettextf("the body of the generic function for %s calls 'standardGeneric' to dispatch on a different name (\"%s\")!",
-# sQuote(fname),
-# paste(as.character(x[[2L]]), collapse = "\n")),
-# domain = NA)
-# TRUE
-# }
-# else {
-# for(i in seq.int(from=2L, length.out = length(x)-1L)) {
-# if(Recall(x[[i]], fname))
-# return(TRUE)
-# }
-# FALSE
-# }
-# }
-# else if(is(x, "language")) {
-# for(i in seq.int(from=2L, length.out = length(x)-1L)) {
-# if(Recall(x[[i]], fname))
-# return(TRUE)
-# }
-# FALSE
-# }
-# else
-# FALSE
-#}
-#
-#.NonstandardGenericTest <- function(body, fname, stdBody)
-#{
-# if(identical(body, stdBody))
-# FALSE
-# else if(.recursiveCallTest(body, fname))
-# TRUE
-# else
-# NA
-#}
-#
-#.GenericInPrimitiveMethods <- function(mlist, f)
-#{
-# methods <- mlist@methods
-# for(i in seq_along(methods)) {
-# mi <- methods[[i]]
-# if(is(mi, "function")) {
-# body(mi, envir = environment(mi)) <-
-# substitute({.Generic <- FF; BODY},
-# list(FF = f,BODY = body(mi)))
-# }
-# else if(is(mi, "MethodsList"))
-# mi <- Recall(mi, f)
-# else
-# stop(sprintf("internal error: Bad methods list object in fixing methods for primitive function %s",
-# sQuote(f)),
-# domain = NA)
-# methods[[i]] <- mi
-# }
-# mlist@methods <- methods
-# mlist
-#}
-#
-#.signatureString <- function(fdef, signature)
-#{
-# snames <- names(signature)
-# if(is.null(snames)) {
-# if(is(fdef, "genericFunction")) {
-# snames <- fdef@signature
-# signature <- matchSignature(signature, fdef)
-# if(length(snames) > length(signature))
-# length(snames) <- length(signature)
-# }
-# else # shouldn't happen,...
-# return(paste(signature, collapse=", "))
-# }
-# else
-# signature <- as.character(signature)
-# paste(paste0(snames, "=\"", signature, "\""), collapse = ", ")
-#}
-#
-#.ChangeFormals <- function(def, defForArgs, msg = "<unidentified context>")
-#{
-# if(!is(def, "function"))
-# stop(gettextf("trying to change the formal arguments in %s in an object of class %s; expected a function definition",
-# msg, dQuote(class(def))),
-# domain = NA)
-# if(!is(defForArgs, "function"))
-# stop(gettextf("trying to change the formal arguments in %s, but getting the new formals from an object of class %s; expected a function definition",
-# msg, dQuote(class(def))),
-# domain = NA)
-# old <- formalArgs(def)
-# new <- formalArgs(defForArgs)
-# if(length(old) < length(new))
-# stop(gettextf("trying to change the formal arguments in %s, but the number of existing arguments is less than the number of new arguments: (%s) vs (%s)",
-# msg, paste0("\"", old, "\"", collapse=", "),
-# paste0("\"", new, "\"", collapse=", ")),
-# domain = NA)
-# if(length(old) > length(new))
-# warning(gettextf("trying to change the formal arguments in %s, but the number of existing arguments is greater than the number of new arguments (the extra arguments won't be used): (%s) vs (%s)",
-# msg, paste0("\"", old, "\"", collapse=", "),
-# paste0("\"", new, "\"", collapse=", ")),
-# domain = NA)
-# if(identical(old, new)) # including the case of 0 length
-# return(def)
-# dlist <- as.list(def)
-# slist <- lapply(c(old, new), as.name)
-# names(slist) <- c(new, old)
-# vlist <- dlist
-# for(i in seq_along(vlist))
-# vlist[[i]] <- do.call("substitute", list(vlist[[i]], slist))
-# dnames <- names(dlist)
-# whereNames <- match(old, dnames)
-# if(anyNA(whereNames))
-# stop(gettextf("in changing formal arguments in %s, some of the old names are not in fact arguments: %s",
-# msg, paste0("\"", old[is.na(match(old, names(dlist)))], "\"", collapse=", ")),
-# domain = NA)
-# dnames[whereNames] <- new
-# names(vlist) <- dnames
-# as.function(vlist, envir = environment(def))
-#}
-#
-### The search list, or a namespace's static search list, or an environment
-#.envSearch <- function(env = topenv(parent.frame()))
-#{
-# if(identical(env, .GlobalEnv))
-# seq_along(search())
-# else if(isNamespace(env) && !isBaseNamespace(env)) {
-# ## the static environments for this namespace, ending with the base namespace
-# value <- list(env)
-# repeat {
-# if(identical(env, emptyenv()))
-# stop("botched namespace: failed to find 'base' namespace in its parents", domain = NA)
-# env <- parent.env(env)
-# value <- c(value, list(env))
-# if(isBaseNamespace(env))
-# break
-# }
-# value
-# }
-# else
-# list(env)
-#}
-#
-#.genericName <- function(f)
-#{
-# if(is(f, "genericFunction"))
-# f@generic
-# else
-# as.character(f)
-#}
-#
-### the environment in which to start searching for methods, etc. related
-### to this generic function. Will normally be the namespace of the generic's
-### home package, or else the global environment
-#.genericEnv <- function(fdef)
-# parent.env(environment(fdef))
-#
-### the default environment in which to start searching for methods, etc. relative to this
-### call to a methods package utility. In the absence of other information, the current
-### strategy is to look at the function _calling_ the methods package utility.
-###TODO: this utility can't really work right until the methods package itself has a
-### namespace, so that calls from within the package can be detected. The
-### heuristic is that all callers are skipped as long as their enviornment is identical
-### to .methodsNamespace. But that is currently initialized to .GlobalEnv.
-###
-### The logic will fail if a function in a package with a namespace calls a (non-methods)
-### function in a package with no namespace, and that function then calls a methods package
-### function. The right answer then is .GlobalEnv, but we will instead get the package
-### namespace.
-#.externalCallerEnv <- function(n = 2, nmax = sys.nframe() - n + 1)
-#{
-# ## start n generations back; by default the caller of the caller to this function
-# ## go back nmax at most (e.g., a function in the methods package that knows it's never
-# ## called more than nmax levels in could supply this argument
-# if(nmax < 1) stop("got a negative maximum number of frames to look at")
-# ev <- topenv(parent.frame()) # .GlobalEnv or the environment in which methods is being built.
-# for(back in seq.int(from = -n, length.out = nmax)) {
-# fun <- sys.function(back)
-# if(is(fun, "function")) {
-# ## Note that "fun" may actually be a method definition, and still will be counted.
-# ## This appears to be the correct semantics, in
-# ## the sense that, if the call came from a method, it's the method's environment
-# ## where one would expect to start the search (for a class definition, e.g.)
-# ev <- environment(fun)
-# if(!identical(ev, .methodsNamespace))
-# break
-# }
-# }
-# ev
-#}
-#
-### a list of environments, starting from ev, going back to the base package,
-### or else terminated by finding a namespace
-#.parentEnvList <- function(ev)
-#{
-# ev <- as.environment(ev)
-# value <- list(ev)
-# while(!isNamespace(ev)) {
-# if(identical(ev, baseenv())) {
-# value[[length(value)]] <- .BaseNamespaceEnv
-# break
-# } else if(identical(ev, emptyenv())) {
-# break
-# }
-# ev <- parent.env(ev)
-# value <- c(value, list(ev))
-# }
-# value
-#}
-#
-#.genericAssign <- function(f, fdef, methods, where, deflt)
-#{
-# ev <- environment(fdef)
-# assign(".Methods", methods, ev)
-#}
-#
-### Mark the method as derived from a non-generic.
-#.derivedDefaultMethod <- function(fdef)
-#{
-# if(is.function(fdef) && !is.primitive(fdef)) {
-# value <- new("derivedDefaultMethod")
-# value@.Data <- fdef
-# value@target <- value@defined <- .newSignature(.anyClassName, formalArgs(fdef))
-# value
-# }
-# else
-# fdef
-#}
-#
-#.identC <- function(c1 = NULL, c2 = NULL)
-#{
-# ## are the two objects identical class or genric function string names?
-# .Call(C_R_identC, c1, c2)
-#}
-#
-### match default exprs in the method to those in the generic
-### if the method does not itself specify a default, and the
-### generic does
-#matchDefaults <- function(method, generic)
-#{
-# changes <- FALSE
-# margs <- formals(method)
-# gargs <- formals(generic)
-# for(arg in names(margs)) {
-# ##!! weird use of missing() here is required by R's definition
-# ## of a missing arg as a name object with empty ("") name
-# ## This is dangerously kludgy code but seems the only way
-# ## to avoid spurious errors ("xxx missing with no default")
-# marg <- margs[[arg]]
-# garg <- gargs[[arg]]
-# if(missing(marg) && !missing(garg)) {
-# changes <- TRUE
-# margs[arg] <- gargs[arg] # NOT [[]], which woud fail for NULL element
-# }
-# }
-# if(changes)
-# formals(method, envir = environment(method)) <- margs
-# method
-#}
-#
-#getGroupMembers <- function(group, recursive = FALSE, character = TRUE)
-#{
-# .recMembers <- function(members, where) {
-# all = vector("list", length(members))
-# for(i in seq_along(members)) {
-# what <- members[[i]]
-# f <- getGeneric(what, FALSE, where)
-# if(!is.null(f))
-# all[[i]] <- what
-# if(is(f, "groupGenericFunction")) {
-# newMem <- f@groupMembers
-# all <- c(all, Recall(newMem, where))
-# }
-# }
-# all
-# }
-# f <- getGeneric(group)
-# if(is.null(f)) {
-# warning(gettextf("%s is not a generic function (or not visible here)",
-# sQuote(f)),
-# domain = NA)
-# return(character())
-# }
-# else if(!is(f, "groupGenericFunction"))
-# character()
-# else {
-# members <- f@groupMembers
-# if(recursive) {
-# where <- f@package
-# if(identical(where, "base")) {
-# where <- "methods" # no generics actually on base
-# members <- .recMembers(members, .methodsNamespace)
-# }
-# else
-# members <- .recMembers(members, .asEnvironmentPackage(where))
-# }
-# if(character)
-# sapply(members, function(x){
-# if(is(x, "character"))
-# x
-# else if(is(x, "genericFunction"))
-# x@generic
-# else
-# stop(gettextf("invalid element in the \"groupMembers\" slot (class %s)",
-# dQuote(class(x))),
-# domain = NA)
-# })
-# else
-# members
-# }
-#}
-#
-#.primname <- function(object)
-#{
-# ## the primitive name is 'as.double', but S4 methods are
-# ## traditionally set on 'as.numeric'
-# f <- .Call(C_R_get_primname, object)
-# if(f == "as.double") "as.numeric" else f
-#}
-#
-#.copyMethodDefaults <- function(generic, method)
-#{
-# emptyDefault <- function(value) missing(value) ||
-# (is.name(value) && nzchar(as.character(value)) )
-# fg <- formals(generic)
-# mg <- formals(method)
-# mgn <- names(mg)
-# changed <- FALSE
-# for(what in names(fg)) {
-# i <- match(what, mgn, 0L)
-# if(i > 0L) {
-# deflt <- mg[[i]]
-# if(!(emptyDefault(deflt) || identical(deflt, fg[[what]]))) {
-# fg[[what]] <- deflt
-# changed <- TRUE
-# }
-# }
-# }
-# if(changed)
-# formals(generic) <- fg
-# generic
-#}
-#
-#.NamespaceOrPackage <- function(what)
-#{
-# name <- as.name(what)
-# ns <- .getNamespace(name)
-# if(!is.null(ns))
-# asNamespace(ns)
-# else {
-# i <- match(paste("package", what, sep=":"), search())
-# if(is.na(i))
-# .GlobalEnv
-# else
-# as.environment(i)
-# }
-#}
-#
-#.NamespaceOrEnvironment <- function(where)
-#{
-# value <- NULL
-# if(is.environment(where))
-# value <- where
-# else if(is.character(where) && nzchar(where)) {
-# ns <- .getNamespace(where)
-# if(isNamespace(ns))
-# value <- ns
-# else if(where %in% search())
-# value <- as.environment(where)
-# else {
-# where <- paste0("package:", where)
-# if(where %in% search())
-# value <- as.environment(where)
-# }
-# }
-# else if(is.numeric(where) && where %in% seq_along(search()))
-# value <- as.environment(where)
-# value
-#}
-#
-#
-.hasS4MetaData <- function(env)
- (length(objects(env, all.names = TRUE,
- pattern = "^[.]__[CTA]_")))
-
-### turn ordinary generic into one that dispatches on "..."
-### currently only called in one place from setGeneric()
-#.dotsGeneric <- function(f)
-#{
-# if(!is(f, "genericFunction"))
-# f <- getGeneric(f)
-# if(!is(f, "genericFunction") || !identical(f@signature, "..."))
-# stop("argument f must be a generic function with signature \"...\"")
-# def <- .standardGenericDots
-# fenv <- environment(f)
-# environment(def) <- fenv
-# assign("standardGeneric", def, envir = fenv)
-# assign(".dotsCall", .makeDotsCall(formalArgs(f)), envir = fenv)
-# f
-#}
-#
-#utils::globalVariables(c(".MTable", ".AllMTable", ".dotsCall"))
-#
-#.standardGenericDots <- function(name)
-#{
-# env <- sys.frame(sys.parent())
-# dots <- eval(quote(list(...)), env)
-# classes <- unique(unlist(lapply(dots, methods:::.class1)))
-# method <- methods:::.selectDotsMethod(classes, .MTable, .AllMTable)
-# if(is.null(method))
-# stop(gettextf("no method or default matching the \"...\" arguments in %s",
-# deparse(sys.call(sys.parent()), nlines = 1)), domain = NA)
-# assign(".Method", method, envir = env)
-# eval(.dotsCall, env)
-#}
-#
-#
-#.quoteCall <- quote(.Method(...))
-#.makeDotsCall <- function(formals)
-#{
-# call <- methods:::.quoteCall
-# if(length(formals) > 1L) {
-# idots <- match("...", formals)
-# for(what in formals[-idots]) {
-# ## the following nonsense is required to get the names in the call
-# ## expression to be empty for ... and there for other args
-# eval(substitute(call$NAME <- as.name(WHAT),
-# list(NAME = as.name(what), WHAT = what)))
-# }
-# }
-# call
-#}
-#
-#.selectDotsMethod <- function(classes, mtable, allmtable)
-#{
-# .pasteC <- function(names) paste0('"', names, '"', collapse = ", ")
-# found <- character()
-# distances <- numeric()
-# methods <- objects(mtable, all.names = TRUE)
-# direct <- match(classes, methods, 0L) > 0L
-# if(all(direct)) {
-# if(length(classes) > 1L) {
-# warning(gettextf("multiple direct matches: %s; using the first of these", .pasteC(classes)), domain = NA)
-# classes <- classes[1L]
-# }
-# else if(length(classes) == 0L)
-# return( if(is.na(match("ANY", methods))) NULL else get("ANY", envir = mtable))
-# return(get(classes,envir = mtable))
-# }
-# if(is.null(allmtable))
-# return(NULL)
-#
-# ## Else, look for an acceptable inherited method, which must match or be a superclass
-# ## of the class of each of the arguments.
-# classes <- sort(classes) # make slection depend only on the set of classes
-# label <- .sigLabel(classes)
-# if(exists(label, envir = allmtable, inherits = FALSE))
-# ## pre-cached, but possibly NULL to indicate no match
-# return(get(label, envir = allmtable))
-# for(i in seq_along(classes)) {
-# classi <- classes[[i]]
-# defi <- getClassDef(classi)
-# if(is.null(defi)) next
-# extendsi <- defi@contains
-# namesi <- c(classi, names(extendsi))
-# if(i == 1)
-# namesi <- namesi[match(namesi, methods, 0L) > 0L]
-# else { # only the superclass methods matching all arguments are kept
-# namesi <- namesi[match(namesi, found, 0L) > 0L]
-# found <- namesi
-# if(length(found) == 0L) break # no possible non-default match
-# }
-# for(namei in namesi) {
-# disti <- if(identical(namei, classi)) 0 else extendsi[[namei]]@distance
-# prev <- match(namei, found)
-# if(is.na(prev)) { # must be the 1st element
-# found <- c(found, namei)
-# distances <- c(distances, disti)
-# }
-# else if(disti < distances[[prev]])
-# distances[[prev]] <- disti
-# }
-# }
-# if(length(found) == 0L)
-# method <- if(is.na(match("ANY", methods))) NULL else get("ANY", envir = mtable)
-# else {
-# classes <- found[which.min(distances)]
-# if(length(classes) > 1L) {
-# warning(gettextf("multiple equivalent inherited matches: %s; using the first of these",
-# .pasteC(classes)), domain = NA)
-# classes <- classes[1L]
-# }
-# method <- get(classes,envir = mtable)
-# }
-# if(!is.null(method))
-# method@target <- new("signature", ... = label) # ?? not a legal class name if > 1 classes
-# assign(label, method, allmtable)
-# method
-#}
-#
-#.isSingleString <- function(what)
-# is.character(what) && identical(nzchar(what), TRUE)
-#
-#.notSingleString <- function(what)
-#{
-# if(identical(what, ""))
-# "non-empty string; got \"\""
-# else if(is.character(what))
-# paste("single string; got a character vector of length", length(what))
-# else
-# gettextf("single string; got an object of class %s",
-# dQuote(class(what)[[1L]]))
-#}
-#
-#.dotsClass <- function(...) {
-# if(missing(..1))
-# "missing"
-# else
-# class(..1)
-#}
-#
-### a utility to exclude various annoying glitches during
-### loading of the methods package
-#.methodsIsLoaded <- function()
-# identical(.saveImage, TRUE)
-#
-#if(FALSE) {
-# ## Defined but not currently used:
-# ## utilitity to test well-defined classes in signature,
-# ## for setMethod(), setAs() [etc.?], the result to be
-# ## assigned in package where=
-# ## Returns a list of signature, messages and level of error
-#
-# ## Has undefined ns an package
-# .validSignature <- function(signature, generic, where) {
-# thisPkg <- getPackageName(where, FALSE)
-# checkDups <- .duplicateClassesExist()
-# if(is(signature, "character")) { # including class "signature"
-# classes <- as.character(signature)
-# names <- allNames(signature)
-# pkgs <- attr(signature, "package")
-# }
-# else if(is(signature, "list")) {
-# classes <- sapply(signature, as.character)
-# names <- names(signature)
-# pkgs <- character(length(signature))
-# for(i in seq_along(pkgs)) {
-# pkgi <- attr(signature[[i]], "package")
-# pkgs[[i]] <- if(is.null(pkgi)) "" else pkgi
-# }
-# }
-# msgs <- character(); level <- integer()
-# for(i in seq_along(classes)) {
-# ## classes must be defined
-# ## if duplicates exist check for them
-# ## An ambiguous duplicate is a warning if it can match thisPkg
-# ## else, an error
-# classi <- classes[[i]]
-# pkgi <- pkgs[[i]]
-# classDefi <- getClass(classi, where = where)
-# if(checkDups &&
-# classi %in% mulipleClasses()) { # hardly ever, we hope
-# clDefsi <- get(classi, envir = .classTable)
-# if(nzchar(pkgi) && pkgi %in% names(clDefsi))
-# ## use the chosen class, no message
-# classDefi <- clDefsi[[pkgi]]
-# else if(nzchar(pkgi)){
-# ## this is only a warning because it just might
-# ## be the result of identical class defs (e.g., from setOldClass()
-# msgs <- c(msgs,
-# gettextf("multiple definitions exist for class %s, but the supplied package (%s) is not one of them (%s)",
-# dQuote(classi), sQuote(pkgi),
-# paste(dQuote(get(classi, envir = .classTable)), collapse = ", ")))
-# level <- c(level, 2) #warn
-# }
-# else {
-# msgs <- c(msgs,
-# gettextf("multiple definitions exist for class %s; should specify one of them (%s), e.g. by className()",
-# dQuote(classi),
-# paste(dQuote(get(classi, envir = .classTable)), collapse = ", ")))
-# }
-# }
-# else {
-# ## just possibly the first reference to an available
-# ## package not yet loaded. It's an error to specify
-# ## a non-loadable package
-# if(nzchar(pkgi)) {
-# loadNamespace(pkgi)
-# classDefi <- getClass(classi, where = ns)
-# }
-# if(is.null(classDefi)) {
-# classDefi <- getClassDef
-# msgi <- gettextf("no definition found for class %s",
-# dQuote(classi))
-# ## ensure only one error message
-# if(length(level) && any(level == 3))
-# msgs[level == 3] <- paste(msgs[level == 3], msgi, sep = "; ")
-# else
-# msgs <- c(msgs, msgi)
-# level <- c(level, 3)
-# }
-# ## note that we do not flag a pkgi different from
-# ## the package of the def., mainly because of setOldClass()
-# ## which currently generates potentially multiple versions
-# ## of the same S3 class.
-# }
-# ## except for the obscure multiple identical class case
-# ## we should not get here w/o a valid class def.
-# if(is.null(classDefi)) {}
-# else
-# pkgs[[i]] <- classDefi@package
-# }
-# signature <- .MakeSignature(new("signature"), generic,
-# structure(classes, names = names, package = package))
-# if(length(msgs) > 1) {
-# ## sort by severity, to get all messages before errror
-# ii <- sort.list(level)
-# msgs <- msgs[ii]; level <- level[ii]
-# }
-# list(signature = signature, message = msgs, level = level)
-# }
-#}
-#
-#.ActionMetaPattern <- function()
-# paste0("^[.]",substring(methodsPackageMetaName("A",""),2))
-#
-#.actionMetaName <- function(name)
-# methodsPackageMetaName("A", name)
-#
-#
-#.doLoadActions <- function(where, attach) {
-# ## at the moment, no unload actions
-# if(!attach)return()
-# actionListName <- .actionMetaName("")
-# if(!exists(actionListName, envir = where, inherits = FALSE))
-# return(list())
-# actions <- get(actionListName, envir = where)
-# ## check sanity: methods must be loaded
-# if(! "package:methods" %in% search()) {
-# warning("trying to execute load actions without 'methods' package")
-# library(methods)
-# }
-# for(what in actions) {
-# aname <- .actionMetaName(what)
-# if(!exists(aname, envir = where, inherits = FALSE)) {
-# warning(gettextf("missing function for load action: %s", what))
-# next
-# }
-# f <- get(aname, envir = where)
-# value <- eval(substitute(tryCatch(FUN(WHERE), error = function(e)e),
-# list(FUN = f, WHERE = where)), where)
-# if(is(value, "error")) {
-# callString <- deparse(value$call)[[1]]
-# stop(gettextf("error in load action %s for package %s: %s: %s",
-# aname, getPackageName(where), callString, value$message))
-# }
-# }
-#}
-#
-#setLoadAction <- function(action,
-# aname = "",
-# where = topenv(parent.frame())) {
-# currentAnames <- .assignActionListNames(where)
-# if(!nzchar(aname))
-# aname <- paste0(".", length(currentAnames)+1)
-# .assignActions(list(action), aname, where)
-# if(is.na(match(aname, currentAnames))) {
-# actionListName <- .actionMetaName("")
-# assign(actionListName, c(currentAnames, aname), envir = where)
-# }
-#}
-#
-#.assignActions <- function(actions, anames, where) {
-# ## check all the actions before assigning any
-# for(i in seq_along(actions)) {
-# f <- actions[[i]]
-# fname <- anames[[i]]
-# if(!is(f, "function"))
-# stop(gettextf("non-function action: %s",
-# sQuote(fname)),
-# domain = NA)
-# if(length(formals(f)) == 0)
-# stop(gettextf("action function %s has no arguments, should have at least 1",
-# sQuote(fname)),
-# domain = NA)
-# }
-# for(i in seq_along(actions))
-# assign(.actionMetaName(anames[[i]]), actions[[i]], envir = where)
-#}
-#
-#.assignActionListNames <- function(where) {
-# actionListName <- .actionMetaName("")
-# if(exists(actionListName, envir = where, inherits = FALSE))
-# get(actionListName, envir = where)
-# else
-# character()
-#}
-#
-#setLoadActions <- function(..., .where = topenv(parent.frame())) {
-# actionListName <- .actionMetaName("")
-# currentAnames <- .assignActionListNames(.where)
-# actions <- list(...)
-# anames <- allNames(actions)
-# ## first, replacements
-# previous <- anames %in% currentAnames
-# if(any(previous)) {
-# .assignActions(actions[previous], anames[previous], .where)
-# if(all(previous))
-# return(list())
-# anames <- anames[!previous]
-# actions <- actions[!previous]
-# }
-# anon <- !nzchar(anames)
-# if(any(anon)) {
-# n <- length(currentAnames)
-# deflts <- paste0(".",seq(from = n+1, length.out = length(actions)))
-# anames[anon] <- deflts[anon]
-# }
-# .assignActions(actions, anames, .where)
-# assign(actionListName, c(currentAnames, anames), envir = .where)
-#}
-#
-#hasLoadAction <- function(aname, where = topenv(parent.frame()))
-# exists(.actionMetaName(aname), envir = where, inherits = FALSE)
-#
-#getLoadActions <- function(where = topenv(parent.frame())) {
-# actionListName <- .actionMetaName("")
-# if(!exists(actionListName, envir = where, inherits = FALSE))
-# return(list())
-# actions <- get(actionListName, envir = where)
-# if(length(actions)) {
-# allExists <- sapply(actions, function(what) exists(.actionMetaName(what), envir = where, inherits = FALSE))
-# if(!all(allExists)) {
-# warning(gettextf("some actions are missing: %s",
-# paste(actions[!allExists], collapse =", ")),
-# domain = NA)
-# actions <- actions[allExists]
-# }
-# allFuns <- lapply(actions, function(what) get(.actionMetaName(what), envir = where))
-# names(allFuns) <- actions
-# allFuns
-# }
-# else
-# list()
-#}
-#
-#evalOnLoad <- function(expr, where = topenv(parent.frame()), aname = "") {
-# f <- function(env)NULL
-# body(f, where) <- substitute(eval(EXPR,ENV), list(EXPR = expr, ENV = where))
-# setLoadAction(f, aname, where)
-#}
-#
-#evalqOnLoad <- function(expr, where = topenv(parent.frame()), aname = "")
-# evalOnLoad(substitute(expr), where, aname)
-#
-### a utility function used to flag non-generics at the loadNamespace phase
-### The calculation there used to ignore the generic cache, which is wrong logic
-### if the package being loaded had a DEPENDS on a package containing the generic
-### version of the function.
-#.findsGeneric <- function(what, ns) {
-# if(is(get(what, mode = "function", envir = ns), "genericFunction"))
-# 1L
-# else if(!is.null(.getGenericFromCache(what, ns)))
-# 2L
-# else
-# 0L
-#}
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/SClasses.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/SClasses.R
deleted file mode 100644
index a73bceb8f45114048378b3d62e22f86bcfed2c09..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/SClasses.R
+++ /dev/null
@@ -1,1017 +0,0 @@
-# File src/library/methods/R/SClasses.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2013 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-setClass <-
- ## Define Class to be an S4 class.
- function(Class, representation = list(), prototype = NULL,
- contains = character(), validity = NULL, access = list(),
- where = topenv(parent.frame()), version = .newExternalptr(),
- sealed = FALSE, package = getPackageName(where),
- S3methods = FALSE, slots)
-{
- oldDef <- getClassDef(Class, where)
- if(is(oldDef, "classRepresentation") && oldDef@sealed)
- stop(gettextf("%s has a sealed class definition and cannot be redefined",
- dQuote(Class)),
- domain = NA)
- if(!missing(slots)) {
- ## The modern version consistent with reference classes
- ## Arguments slots= and contains= are used, representation must not be
- if(!missing(representation))
- stop("Argument \"representation\" cannot be used if argument \"slots\" is supplied")
- properties <- inferProperties(slots, "slot")
- classDef <- makeClassRepresentation(Class, properties,contains, prototype, package,
- validity, access, version, sealed, where = where)
- superClasses <- names(classDef@contains)
- }
- else if(is(representation, "classRepresentation")) {
- ## supplied a class definition object
- classDef <- representation
- if(!(missing(prototype) && missing(contains) && missing(validity) && missing(access)
- && missing(version) && missing(package)))
- stop("only arguments 'Class' and 'where' can be supplied when argument 'representation' is a 'classRepresentation' object")
- if(length(classDef@package) == 0L)
- classDef@package <- package # the default
- superClasses <- allNames(classDef@contains)
- }
- else {
- ## catch the special case of a single class name as the representation
- if(is.character(representation) && length(representation) == 1L &&
- is.null(names(representation)))
- representation <- list(representation)
- slots <- nzchar(allNames(representation))
- superClasses <- c(as.character(representation[!slots]), contains)
- properties <- representation[slots]
- classDef <- makeClassRepresentation(Class, properties,superClasses, prototype, package,
- validity, access, version, sealed, where = where)
- superClasses <- names(classDef@contains)
- }
- classDef <- completeClassDefinition(Class, classDef, where, doExtends = FALSE)
- ## uncache an old definition for this package, if one is cached
- .uncacheClass(Class, classDef)
- if(length(superClasses) > 0L) {
- sealed <- classDef@sealed
- classDef@sealed <- FALSE # to allow setIs to work anyway; will be reset later
- assignClassDef(Class, classDef, where)
- badContains <- character()
- for(class2 in superClasses) {
- if(is(try(setIs(Class, class2, classDef = classDef, where = where)), "try-error"))
- badContains <- c(badContains, class2)
- else { # update class definition
- classDef <- getClassDef(Class, where = where)
- if(is.null(classDef))
- stop(sprintf("internal error: definition of class %s not properly assigned",
- dQuote(Class)),
- domain = NA)
- }
- }
- if(length(badContains)) {
- msg <- paste(.dQ(badContains), collapse = ", ")
- if(is(try(removeClass(Class, where)), "try-error"))
- stop(gettextf("error in contained classes (%s) for class %s and unable to remove definition from %s",
- msg, dQuote(Class),
- sQuote(getPackageName(where))),
- domain = NA)
- if(is.null(oldDef))
- stop(gettextf("error in contained classes (%s) for class %s; class definition removed from %s",
- msg, dQuote(Class),
- sQuote(getPackageName(where))),
- domain = NA)
- else if(is(try(setClass(Class, oldDef, where=where)), "try-error"))
- stop(gettextf("error in contained classes (%s) for class %s and unable to restore previous definition from %s",
- msg, dQuote(Class),
- sQuote(getPackageName(where))),
- domain = NA)
- else
- stop(gettextf("error in contained classes (%s) for class %s; previous definition restored to %s",
- msg, dQuote(Class),
- sQuote(getPackageName(where))),
- domain = NA)
- }
- if(length(attr(classDef@contains, "conflicts")) > 0)
- .reportSuperclassConflicts(Class, classDef@contains, where)
- .checkRequiredGenerics(Class, classDef, where)
- if(sealed) {
- classDef@sealed <- TRUE
- }
- }
- if(S3methods)
- classDef <- .setS3MethodsOn(classDef)
- assignClassDef(Class, classDef, where)
- invisible(classGeneratorFunction(classDef, where))
-}
-
-representation <-
- ## Representation of a class; that is,
- ## a list of named slots and unnamed classes to be included in a class
- ## definition.
- function(...)
-{
- value <- list(...)
- ## unlike the S-Plus function, this does not form the class representation,
- ## since set SClass works separately with the slots and extends arguments.
- anames <- allNames(value)
- for(i in seq_along(value)) {
- ei <- el(value, i)
- if(!is.character(ei) || length(ei) != 1L)
- stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
- }
- includes <- as.character(value[!nzchar(anames)])
- if(anyDuplicated(includes))
- stop(gettextf("duplicate class names among superclasses: %s",
- paste(.dQ(includes[duplicated(includes)]),
- collapse = ", ")),
- domain = NA)
- slots <- anames[nzchar(anames)]
- if(anyDuplicated(slots)) {
- dslots <- slots[duplicated(slots)]
- stop(sprintf(ngettext(length(dslots),
- "duplicated slot name: %s",
- "duplicated slot names: %s"),
- paste(sQuote(dslots), collapse="")),
- domain = NA)
- }
- value
-}
-
-### the version called prototype is the external interface. But functions with argument
-### named prototype in R cannot call the prototype function (until there is a methods namespace
-### to allow methods::prototype(...)
-prototype <- function(...)
- .prototype(...)
-
-.prototype <- function(...) {
- props <- list(...)
- names <- allNames(props)
- data <- !nzchar(names)
- dataPart <- any(data)
- if(dataPart) {
- if(sum(data) > 1)
- stop("only one data object (unnamed argument to prototype) allowed")
- obj <- unclass(props[[seq_along(data)[data] ]])
- props <- props[!data]
- names <- names[!data]
- }
- else
- obj <- defaultPrototype()
- for(i in seq_along(names))
- slot(obj, names[[i]], FALSE) <- props[[i]]
- new("classPrototypeDef", object = obj, slots = names, dataPart = dataPart)
-}
-
-makeClassRepresentation <-
- ## Set the Class Definition.
- ## The formal definition of the class is set according to the arguments.
- ##
- ## Users should call setClass instead of this function.
- function(name, slots = list(), superClasses = character(), prototype = NULL, package, validity = NULL, access = list(), version = .newExternalptr(), sealed = FALSE, virtual = NA, where)
-{
- if(any(superClasses %in% .AbnormalTypes))
- superClasses <- .addAbnormalDataType(superClasses)
- if(!is.null(prototype) || length(slots) || length(superClasses)) {
- ## collect information about slots, create prototype if needed
- pp <- reconcilePropertiesAndPrototype(name, slots, prototype, superClasses, where)
- slots <- pp$properties
- prototype <- pp$prototype
- }
- contains <- list()
- if(nzchar(package))
- packageSlot(name) <- package
- for(what in superClasses) {
- if(is(what, "classRepresentation"))
- whatClassDef <- what
- else if(is.null(packageSlot(what)))
- whatClassDef <- getClass(what, where = where)
- else
- whatClassDef <- getClass(what)
- what <- whatClassDef@className # includes package name as attribute
- ## Create the SClassExtension objects (will be simple, possibly dataPart).
- ## The slots are supplied explicitly, since `name' is currently an undefined class
- elNamed(contains, what) <- makeExtends(name, what, slots = slots,
- classDef2 = whatClassDef, package = package)
- }
- validity <- .makeValidityMethod(name, validity)
- if(is.na(virtual)) {
- virtual <- testVirtual(slots, contains, prototype, where)
- if(virtual && !is.na(match("VIRTUAL", superClasses)))
- elNamed(contains, "VIRTUAL") <- NULL
- }
- # new() must return an S4 object, except perhaps for basic classes
- if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
- prototype <- .asS4(prototype)
- if(".S3Class" %in% names(slots))
- prototype <- .addS3Class(name, prototype, contains, where)
- newClassRepresentation(className = name, slots = slots,
- contains = contains,
- prototype = prototype,
- virtual = virtual,
- validity = validity,
- access = access,
- package = package,
- versionKey = version,
- sealed = sealed)
-}
-
-getClassDef <-
- ## Get the definition of the class supplied as a string.
- function(Class, where = topenv(parent.frame()), package = packageSlot(Class),
- inherits = TRUE)
-{
- if(inherits) #includes both the lookup and Class being alread a definition
- value <- .getClassFromCache(Class, where)
- else # want to force a search for the metadata in this case (Why?)
- value <- NULL
- if(is.null(value)) {
- cname <-
- classMetaName(if(length(Class) > 1L)
- ## S3 class; almost certainly has no packageSlot,
- ## but we'll continue anyway
- Class[[1L]] else Class)
- ## a string with a package slot strongly implies the class definition
- ## should be in that package.
- if(identical(nzchar(package), TRUE)) {
- whereP <- .requirePackage(package)
- if(exists(cname, whereP, inherits = inherits))
- value <- get(cname, whereP)
- }
- if(is.null(value) && exists(cname, where, inherits = inherits))
- value <- get(cname, where)
- }
- value
-}
-
-getClass <-
- ## Get the complete definition of the class supplied as a string,
- ## including all slots, etc. in classes that this class extends.
- function(Class, .Force = FALSE,
- where = .classEnv(Class, topenv(parent.frame()), FALSE))
-{
- value <- .getClassFromCache(Class, where) # the quick way
- if(is.null(value)) {
- value <- getClassDef(Class, where) # searches
- if(is.null(value)) {
- if(!.Force)
- stop(gettextf("%s is not a defined class",
- dQuote(Class)),
- domain = NA)
- else
- value <- makeClassRepresentation(Class, package = "base",
- virtual = TRUE, where = where)
- }
- }
- value
-}
-
-slot <-
- ## Get the value of the named slot. This function does exact, not partial, matching of names,
- ## and the name must be one of the slot names specified in the class's definition.
- ##
- ## Because slots are stored as attributes, the validity check is not 100% guaranteed,
- ## but should be OK if nobody has "cheated" (e.g., by setting other attributes directly).
- function(object, name)
- .Call(C_R_get_slot, object, name)
-
-"slot<-" <-
- ## Set the value of the named slot. Must be one of the slots in the class's definition.
- function(object, name, check = TRUE, value) {
- if(check)
- value <- checkSlotAssignment(object, name, value)
- .Call(C_R_set_slot, object, name, value)
- ## currently --> R_do_slot_assign() in ../../../main/attrib.c
-}
-
-## ". - hidden" since one should typically rather use is(), extends() etc:
-.hasSlot <- function(object, name)
- .Call(C_R_hasSlot, object, name)
-
-checkSlotAssignment <- function(obj, name, value)
-{
- cl <- class(obj)
- ClassDef <- getClass(cl) # fails if cl not a defined class (!)
- slotClass <- elNamed(ClassDef@slots, name)
- if(is.null(slotClass))
- stop(gettextf("%s is not a slot in class %s",
- sQuote(name), dQuote(cl)),
- domain = NA)
- valueClass <- class(value)
- if(.identC(slotClass, valueClass))
- return(value)
- ## check the value, but be careful to use the definition of the slot's class from
- ## the class environment of obj (change validObject too if a better way is found)
- ok <- possibleExtends(valueClass, slotClass,
- ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef)))
- if(identical(ok, FALSE))
- stop(gettextf("assignment of an object of class %s is not valid for slot %s in an object of class %s; is(value, \"%s\") is not TRUE",
- dQuote(valueClass), sQuote(name), dQuote(cl), slotClass),
- domain = NA)
- else if(identical(ok, TRUE))
- value
- else
- as(value, slotClass, strict=FALSE, ext = ok)
-}
-
-## slightly simpler verison to be called from do_attrgets()
-checkAtAssignment <- function(cl, name, valueClass)
-{
- ClassDef <- getClass(cl) # fails if cl not a defined class (!)
- slotClass <- elNamed(ClassDef@slots, name)
- if(is.null(slotClass))
- stop(gettextf("%s is not a slot in class %s",
- sQuote(name), dQuote(cl)),
- domain = NA)
- if(.identC(slotClass, valueClass))
- return(TRUE)
- ## check the value, but be careful to use the definition of the slot's class from
- ## the class environment of obj (change validObject too if a better way is found)
- ok <- possibleExtends(valueClass, slotClass,
- ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef)))
- if(identical(ok, FALSE))
- stop(gettextf("assignment of an object of class %s is not valid for @%s in an object of class %s; is(value, \"%s\") is not TRUE",
- dQuote(valueClass), sQuote(name), dQuote(cl), slotClass),
- domain = NA)
- TRUE
-}
-
-## Now a primitive in base
-## "@<-" <-
-## function(object, name, value) {
-## arg <- substitute(name)
-## if(is.name(arg))
-## name <- as.character(arg)
-## "slot<-"(object, name, TRUE, value)
-## }
-
-## The names of the class's slots. The argument is either the name
-## of a class, or an object from the relevant class.
-
-## NOTA BENE: .slotNames() shouldn't be needed,
-## rather slotNames() should be changed (to work like .slotNames())!
-slotNames <- function(x)
- if(is(x, "classRepresentation")) names(x@slots) else .slotNames(x)
-
-.slotNames <- function(x)
-{
- classDef <-
- getClassDef(if(is.character(x) && length(x) == 1L) x else class(x))
- if(is.null(classDef))
- character()
- else
- names(classDef@slots)
-}
-
-
-removeClass <- function(Class, where = topenv(parent.frame())) {
- if(missing(where)) {
- classEnv <- .classEnv(Class, where, FALSE)
- classWhere <- findClass(Class, where = classEnv)
- if(length(classWhere) == 0L) {
- warning(gettextf("class definition for %s not found (no action taken)",
- dQuote(Class)),
- domain = NA)
- return(FALSE)
- }
- if(length(classWhere) > 1L)
- warning(gettextf("class %s has multiple definitions visible; only the first removed",
- dQuote(Class)),
- domain = NA)
- classWhere <- classWhere[[1L]]
- }
- else classWhere <- where
- classDef <- getClassDef(Class, where=classWhere)
- if(length(classDef@subclasses)) {
- subclasses <- names(classDef@subclasses)
- found <- sapply(subclasses, isClass, where = where)
- for(what in subclasses[found])
- .removeSuperClass(what, Class)
- }
- .removeSuperclassBackRefs(Class, classDef, classWhere)
- .uncacheClass(Class, classDef)
- .undefineMethod("initialize", Class, classWhere)
- what <- classMetaName(Class)
- rm(list=what, pos=classWhere)
- TRUE
-}
-
-
-isClass <-
- ## Is this a formally defined class?
- function(Class, formal=TRUE, where = topenv(parent.frame()))
- ## argument formal is for Splus compatibility & is ignored. (All classes that
- ## are defined must have a class definition object.)
- !is.null(getClassDef(Class, where))
-
-### TODO s/Class/._class/ -- in order to allow 'Class' as regular slot name
-new <-
- ## Generate an object from the specified class.
- ##
- ## Note that the basic vector classes, `"numeric"', etc. are implicitly defined,
- ## so one can use `new' for these classes.
- ##
- function(Class, ...)
-{
- ClassDef <- getClass(Class, where = topenv(parent.frame()))
- value <- .Call(C_new_object, ClassDef)
- initialize(value, ...)
-}
-
-getClasses <-
- ## The names of all the classes formally defined on `where'.
- ## If called with no argument, all the classes currently known in the session
- ## (which does not include classes that may be defined on one of the attached
- ## libraries, but have not yet been used in the session).
- function(where = .externalCallerEnv(), inherits = missing(where))
-{
- pat <- paste0("^",classMetaName(""))
- if(inherits) {
- evList <- .parentEnvList(where)
- clNames <- character()
- for(ev in evList)
- clNames <- c(clNames, objects(ev, pattern = pat, all.names = TRUE))
- clNames <- unique(clNames)
- }
- else
- clNames <- objects(where, pattern = pat, all.names = TRUE)
- ## strip off the leading pattern (this implicitly assumes the characters
- ## in classMetaName("") are either "." or not metacharacters
- substring(clNames, nchar(pat, "c"))
-}
-
-
-validObject <- function(object, test = FALSE, complete = FALSE)
-{
- Class <- class(object)
- classDef <- getClassDef(Class)
- where <- .classEnv(classDef)
- anyStrings <- function(x) if(identical(x, TRUE)) character() else x
- ## perform, from bottom up, the default and any explicit validity tests
- ## First, validate the slots.
- errors <- character()
- slotTypes <- classDef@slots
- slotNames <- names(slotTypes)
- attrNames <- c(".Data", ".S3Class", names(attributes(object)))
- if(any(is.na(match(slotNames, attrNames)))) {
- badSlots <- is.na(match(slotNames, attrNames))
- errors <-
- c(errors,
- paste("slots in class definition but not in object:",
- paste0('"', slotNames[badSlots], '"', collapse = ", ")))
- slotTypes <- slotTypes[!badSlots]
- slotNames <- slotNames[!badSlots]
- }
- for(i in seq_along(slotTypes)) {
- classi <- slotTypes[[i]]
- classDefi <- getClassDef(classi, where = where)
- if(is.null(classDefi)) {
- errors <- c(errors,
- paste0("undefined class for slot \"", slotNames[[i]],
- "\" (\"", classi, "\")"))
- next
- }
- namei <- slotNames[[i]]
- sloti <- try(switch(namei,
- ## .S3Class for S3 objects (e.g., "factor")
- .S3Class = S3Class(object),
- slot(object, namei)
- ), silent = TRUE)
- if(inherits(sloti, "try-error")) {
- errors <- c(errors, sloti)
- next
- }
- ## note that the use of possibleExtends is shared with checkSlotAssignment(), in case a
- ## future revision improves on it!
- ok <- possibleExtends(class(sloti), classi, ClassDef2 = classDefi)
- if(identical(ok, FALSE)) {
- errors <- c(errors,
- paste0("invalid object for slot \"", slotNames[[i]],
- "\" in class \"", Class,
- "\": got class \"", class(sloti),
- "\", should be or extend class \"", classi, "\""))
- next
- }
- if(!complete)
- next
- errori <- anyStrings(Recall(sloti, TRUE, TRUE))
- if(length(errori)) {
- errori <- paste0("In slot \"", slotNames[[i]],
- "\" of class \"", class(sloti), "\": ", errori)
- errors <- c(errors, errori)
- }
- }
- extends <- rev(classDef@contains)
- for(i in seq_along(extends)) {
- exti <- extends[[i]]
- superClass <- exti@superClass
- if(!exti@simple && !is(object, superClass))
- next ## skip conditional relations that don't hold for this object
- superDef <- getClassDef(superClass, where = where)
- if(is.null(superDef)) {
- errors <- c(errors,
- paste0("superclass \"", superClass,
- "\" not defined in the environment of the object's class"))
- break
- }
- validityMethod <- superDef@validity
- if(is(validityMethod, "function")) {
- errors <- c(errors, anyStrings(validityMethod(as(object, superClass))))
- if(length(errors))
- break
- }
- }
- validityMethod <- classDef@validity
- if(length(errors) == 0L && is(validityMethod, "function")) {
- errors <- c(errors, anyStrings(validityMethod(object)))
- }
- if(length(errors)) {
- if(test)
- errors
- else {
- msg <- gettextf("invalid class %s object", dQuote(Class))
- if(length(errors) > 1L)
- stop(paste(paste0(msg, ":"),
- paste(seq_along(errors), errors, sep=": "),
- collapse = "\n"), domain = NA)
- else stop(msg, ": ", errors, domain = NA)
- }
- }
- else
- TRUE
-}
-
-setValidity <- function(Class, method, where = topenv(parent.frame())) {
- if(isClassDef(Class)) {
- ClassDef <- Class
- Class <- ClassDef@className
- }
- else {
- ClassDef <- getClassDef(Class, where)
- }
- method <- .makeValidityMethod(Class, method)
- if(is.null(method) ||
- (is(method, "function") && length(formalArgs(method)) == 1L))
- ClassDef@validity <- method
- else
- stop("validity method must be NULL or a function of one argument")
- ## TO DO: check the where argument against the package of the class def.
- assignClassDef(Class, ClassDef, where = where)
- resetClass(Class, ClassDef, where = where)
-}
-
-getValidity <- function (ClassDef) {
- ## "needed" according to ../man/validObject.Rd
- ClassDef@validity
-}
-
-
-resetClass <- function(Class, classDef, where) {
- if(is(Class, "classRepresentation")) {
- classDef <- Class
- Class <- Class@className
- if(missing(where))
- where <- .classDefEnv(classDef)
- }
- else {
- if(missing(where)) {
- if(missing(classDef))
- where <- findClass(Class, unique = "resetting the definition")[[1L]]
- else
- where <- .classDefEnv(classDef)
- }
- if(missing(classDef)) {
- classDef <- getClassDef(Class, where)
- if(is.null(classDef)) {
- warning(gettextf("class %s not found on %s; 'resetClass' will have no effect",
- dQuote(Class),
- sQuote(getPackageName(where))),
- domain = NA)
- return(classDef)
- }
- }
- else if(!is(classDef, "classRepresentation"))
- stop(gettextf("argument 'classDef' must be a string or a class representation; got an object of class %s",
- dQuote(class(classDef))),
- domain = NA)
- package <- getPackageName(where)
- }
- if(classDef@sealed)
- warning(gettextf("class %s is sealed; 'resetClass' will have no effect",
- dQuote(Class)),
- domain = NA)
- else {
- classDef <- .uncompleteClassDefinition(classDef)
- classDef <- completeClassDefinition(Class, classDef, where)
- assignClassDef(Class, classDef, where)
- }
- classDef
-}
-
-## the (default) initialization: becomes the default method when the function
-## is made a generic by .InitMethodDefinitions
-
-initialize <- function(.Object, ...) {
- args <- list(...)
- if(length(args)) {
- Class <- class(.Object)
- ## the basic classes have fixed definitions
- if(!is.na(match(Class, .BasicClasses)))
- return(newBasic(Class, ...))
- ClassDef <- getClass(Class)
- ## separate the slots, superclass objects
- snames <- allNames(args)
- which <- nzchar(snames)
- elements <- args[which]
- supers <- args[!which]
- thisExtends <- names(ClassDef@contains)
- slotDefs <- ClassDef@slots
- dataPart <- elNamed(slotDefs, ".Data")
- if(is.null(dataPart)) dataPart <- "missing"
- if(length(supers)) {
- for(i in rev(seq_along(supers))) {
- obj <- el(supers, i)
- Classi <- class(obj)
- if(length(Classi) > 1L)
- Classi <- Classi[[1L]] #possible S3 inheritance
- ## test some cases that let information be copied into the
- ## object, ordered from more to less: all the slots in the
- ## first two cases, some in the 3rd, just the data part in 4th
- if(.identC(Classi, Class))
- .Object <- obj
- else if(extends(Classi, Class))
- .Object <- as(obj, Class, strict=FALSE)
- else if(extends(Class, Classi))
- as(.Object, Classi) <- obj
- else if(extends(Classi, dataPart))
- .Object@.Data <- obj
- else {
- ## is there a class to which we can coerce obj
- ## that is then among the superclasses of Class?
- extendsi <- extends(Classi)[-1L]
- ## look for the common extensions, choose the first
- ## one in the extensions of Class
- which <- match(thisExtends, extendsi)
- which <- seq_along(which)[!is.na(which)]
- if(length(which)) {
- Classi <- thisExtends[which[1L]]
- ### was: as(.Object, Classi) <- as(obj, Classi, strict = FALSE)
- ## but as<- does an as(....) to its value argument
- as(.Object, Classi) <- obj
- }
- else
- stop(gettextf("cannot use object of class %s in new(): class %s does not extend that class",
- dQuote(Classi),
- dQuote(Class)),
- domain = NA)
- }
- }
- }
- if(length(elements)) {
- snames <- names(elements)
- if(anyDuplicated(snames))
- stop(gettextf("duplicated slot names: %s",
- paste(sQuote(snames[duplicated(snames)]),
- collapse = ", ")), domain = NA)
- which <- match(snames, names(slotDefs))
- if(anyNA(which))
- stop(sprintf(ngettext(sum(is.na(which)),
- "invalid name for slot of class %s: %s",
- "invalid names for slots of class %s: %s"),
- dQuote(Class),
- paste(snames[is.na(which)], collapse=", ")),
- domain = NA)
- firstTime <- TRUE
- for(i in seq_along(snames)) {
- slotName <- el(snames, i)
- slotClass <- elNamed(slotDefs, slotName)
- slotClassDef <- getClassDef(slotClass, package=ClassDef@package)
- slotVal <- el(elements, i)
- ## perform non-strict coercion, but leave the error messages for
- ## values not conforming to the slot definitions to validObject(),
- ## hence the check = FALSE argument in the slot assignment
- if(!.identC(class(slotVal), slotClass)
- && !is.null(slotClassDef) ) {
- valClass <- class(slotVal)
- valClassDef <- getClassDef(valClass, package = ClassDef@package)
- if(!identical(possibleExtends(valClass, slotClass,
- valClassDef, slotClassDef), FALSE))
- slotVal <- as(slotVal, slotClass, strict = FALSE)
- }
- if (firstTime) {
- ## force a copy of .Object
- slot(.Object, slotName, check = FALSE) <- slotVal
- firstTime <- FALSE
- } else {
- ## XXX: do the assignment in-place
- "slot<-"(.Object, slotName, check = FALSE, slotVal)
- }
- }
- }
- validObject(.Object)
- }
- .Object
-}
-
-findClass <- function(Class, where = topenv(parent.frame()), unique = "") {
- if(is(Class, "classRepresentation")) {
- pkg <- Class@package
- classDef <- Class
- Class <- Class@className
- }
- else {
- pkg <- packageSlot(Class)
- if(is.null(pkg))
- pkg <- ""
- classDef <- getClassDef(Class, where, pkg)
- }
- if(missing(where) && nzchar(pkg))
- where <- .requirePackage(pkg)
- else
- where <- as.environment(where)
- what <- classMetaName(Class)
- where <- .findAll(what, where)
- if(length(where) > 1L && nzchar(pkg)) {
- pkgs <- sapply(where, function(db)get(what, db)@package)
- where <- where[match(pkg, pkgs, 0L)]
- }
- else
- pkgs <- pkg
- if(length(where) == 0L) {
- if(is.null(classDef))
- classDef <- getClassDef(Class) # but won't likely succeed over previous
- if(nzchar(unique)) {
- if(is(classDef, "classRepresentation"))
- stop(gettextf("class %s is defined, with package %s, but no corresponding metadata object was found (not exported?)",
- dQuote(Class),
- sQuote(classDef@package)),
- domain = NA)
- else
- stop(gettextf("no definition of %s to use for %s",
- dQuote(Class),
- unique),
- domain = NA)
- }
- }
- else if(length(where) > 1L) {
- pkgs <- sapply(where, getPackageName, create = FALSE)
- ## not all environments need be packages (e.g., imports)
- ## We only try to eliminate duplicate package namespaces
- where <- where[!(nzchar(pkgs) & duplicated(pkgs))]
- if(length(where) > 1L)
- if(nzchar(unique)) {
- pkgs <- base::unique(pkgs)
- where <- where[1L]
- ## problem: 'unique'x is text passed in, so do not translate
- warning(sprintf(ngettext(length(pkgs),
- "multiple definition of class %s visible (%s); using the definition\n in package %s for %s",
- "multiple definitions of class %s visible (%s); using the definition\n in package %s for %s"),
- dQuote(Class),
- paste(sQuote(pkgs), collapse = ", "),
- sQuote(pkgs[[1L]]),
- unique),
- domain = NA)
- }
- ## else returns a list of >1 places, for the caller to sort out (e.g., .findOrCopyClass)
- }
- where
-}
-
-isSealedClass <- function(Class, where = topenv(parent.frame())) {
- if(is.character(Class))
- Class <- getClass(Class, TRUE, where)
- if(!is(Class, "classRepresentation"))
- FALSE
- else
- Class@sealed
-}
-
-sealClass <- function(Class, where = topenv(parent.frame())) {
- if(missing(where))
- where <- findClass(Class, unique = "sealing the class", where = where)
- classDef <- getClassDef(Class, where)
- if(!classDef@sealed) {
- classDef@sealed <- TRUE
- assignClassDef(Class, classDef, where)
- }
- invisible(classDef)
-}
-
-## see $RHOME/src/main/duplicate.c for the corresponding datatypes
-## not copied by duplicate1
-.AbnormalTypes <- c("environment", "name", "externalptr", "NULL")
-
-
-.indirectAbnormalClasses <- paste0(".", .AbnormalTypes)
-names(.indirectAbnormalClasses) <- .AbnormalTypes
-
-## the types not supported by indirect classes (yet)
-.AbnormalTypes <- c(.AbnormalTypes,
- "special","builtin", "weakref", "bytecode")
-
-.addAbnormalDataType <- function(classes) {
- types <- match(classes, .AbnormalTypes, 0) > 0
- type = classes[types]
- if(length(type) == 0)
- return(classes)
- if(length(type) > 1)
- stop(gettextf("class definition cannot extend more than one of these data types: %s",
- paste0('"',type, '"', collapse = ", ")),
- domain = NA)
- class <- .indirectAbnormalClasses[type]
- if(is.na(class))
- stop(gettextf("abnormal type %s is not supported as a superclass of a class definition",
- dQuote(type)),
- domain = NA)
- ## this message USED TO BE PRINTED: reminds programmers that
- ## they will see an unexpected superclass
- ## message(gettextf('Defining type "%s" as a superclass via class "%s"',
- ## type, class), domain = NA)
- c(class, classes[!types])
-}
-
-.checkRequiredGenerics <- function(Class, classDef, where) {}
-
-..checkRequiredGenerics <- function(Class, classDef, where) {
- ## If any of the superclasses are in the .NeedPrimitiveMethods
- ## list, cache the corresponding generics now and also save their names in
- ## .requireCachedGenerics to be used when the environment
- ## where= is loaded.
- supers <- names(classDef@contains)
- allNeeded <- get(".NeedPrimitiveMethods", envir = .methodsNamespace)
- specials <- names(allNeeded)
- needed <- match(specials, supers, 0) > 0
- if(any(needed)) {
- generics <- unique(allNeeded[needed])
- packages <- character()
- for(g in generics) {
- def <- getGeneric(g)
- packages <- c(packages, def@package) # must be "methods" ?
- cacheGenericsMetaData(g, def, TRUE, where, def@package)
- }
- if(exists(".requireCachedGenerics", where, inherits = FALSE))
- previous <- get(".requireCachedGenerics", where)
- else
- previous <- character()
- packages <- c(attr(previous, "package"), packages)
- gg <- c(previous, generics)
- attr(gg, "package") <- packages
- assign(".requireCachedGenerics", gg, where)
- }
-}
-
-.setS3MethodsOn <- function(classDef) {
- ext <- extends(classDef)
- slots <- classDef@slots
- if(is.na(match(".S3Class", names(slots)))) {
- ## add the slot if it's not there
- slots$.S3Class <- getClass("oldClass")@slots$.S3Class
- classDef@slots <- slots
- }
- ## in any case give the prototype the full extends as .S3Class
- proto <- classDef@prototype
- if(is.null(proto)) # simple virtual class--unlikely but valid
- proto <- defaultPrototype()
- attr(proto, ".S3Class") <- ext
- classDef@prototype <- proto
- classDef
-}
-
-multipleClasses <- function(details = FALSE) {
- ctable <- .classTable
- cnames <- objects(ctable, all.names = TRUE)
- dups <- sapply(cnames, function(x) is.list(get(x, envir = ctable)))
- if(details) {
- value <- lapply(cnames[dups], function(x) get(x, envir = ctable))
- names(value) <- cnames[dups]
- value
- }
- else
- cnames[dups]
-}
-
-className <- function(class, package) {
- if(is(class, "character")) {
- className <- as.character(class)
- if(missing(package))
- package <- packageSlot(class)
- if(is.null(package)) {
- if(exists(className, envir = .classTable, inherits = FALSE))
- classDef <- get(className, envir = .classTable)
- else {
- classDef <- findClass(className, topenv(parent.frame()))
- if(length(classDef) == 1)
- classDef <- classDef[[1]]
- }
- ## at this point, classDef is the definition if
- ## unique, otherwise a list of 0 or >1 definitions
- if(is(classDef, "classRepresentation"))
- package <- classDef@package
- else if(length(classDef) > 1L) {
- pkgs <- sapply(classDef, function(cl)cl@package)
- warning(gettextf("multiple class definitions for %s from packages: %s; picking the first",
- dQuote(className),
- paste(sQuote(pkgs), collapse = ", ")),
- domain = NA)
- package <- pkgs[[1L]]
- }
- else
- stop(gettextf("no package name supplied and no class definition found for %s",
- dQuote(className)),
- domain = NA)
- }
- }
- else if(is(class, classDef)) {
- className <- class@className
- if(missing(package))
- package <- class@package
- }
- new("className", .Data = className, package = package)
-}
-
-## bootstrap version before the class is defined
-classGeneratorFunction <- function(classDef, env = topenv(parent.frame())) {
- fun <- function(...)NULL
- ## put the class name with package attribute into new()
- body(fun) <- substitute(new(CLASS, ...),
- list(CLASS = classDef@className))
- environment(fun) <- env
- fun
-}
-
-.classGeneratorFunction <- function(classDef, env = topenv(parent.frame())) {
- if(is(classDef, "classRepresentation")) {}
- else if(is(classDef, "character")) {
- if(is.null(packageSlot(classDef)))
- classDef <- getClass(classDef, where = env)
- else
- classDef <- getClass(classDef)
- }
- else
- stop("argument 'classDef' must be a class definition or the name of a class")
- fun <- function(...)NULL
- ## put the class name with package attribute into new()
- body(fun) <- substitute(new(CLASS, ...),
- list(CLASS = classDef@className))
- environment(fun) <- env
- fun <- as(fun, "classGeneratorFunction")
- fun@className <- classDef@className
- fun@package <- classDef@package
- fun
-}
-
-## grammar: 'what' is an adjective, so not plural ....
-inferProperties <- function(props, what) {
- .validPropNames <- function(propNames) {
- n <- length(props)
- if(!n)
- return(character())
- else if(is.null(propNames))
- stop(gettextf("No %s names supplied", what),
- domain = NA, call. = FALSE)
- else if(!all(nzchar(propNames)))
- stop(gettextf("All %s names must be nonempty in:\n(%s)", what,
- paste(sQuote(propNames), collapse = ", ")),
- domain = NA, call. = FALSE)
- else if(any(duplicated(propNames))) # NB: not translatable because of plurals
- stop(gettextf("All %s names must be distinct in:\n(%s)", what,
- paste(sQuote(propNames), collapse = ", ")),
- domain = NA, call. = FALSE)
- propNames
- }
- if(is.character(props)) {
- propNames <- names(props)
- if(is.null(propNames)) {
- propNames <- .validPropNames(props) # the text is the names
- ## treat as "ANY"
- props <- as.list(rep("ANY", length(props)))
- names(props) <- propNames
- }
- else {
- .validPropNames(propNames)
- props <- as.list(props)
- }
- }
- else if(is.list(props)) {
- if(length(props) > 0) # just validate them
- .validPropNames(names(props))
- }
- else
- stop(gettextf("argument %s must be a list or a character vector; got an object of class %s",
- dQuote(what), dQuote(class(fields))),
- domain = NA)
- props
-}
-
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/is.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/is.R
deleted file mode 100644
index da6ab3d6b01287695f56691d7216005fec146047..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/is.R
+++ /dev/null
@@ -1,272 +0,0 @@
-# File src/library/methods/R/is.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-is <-
- # With two arguments, tests whether `object' can be treated as from `class2'.
- #
- # With one argument, returns all the super-classes of this object's class.
- function(object, class2)
-{
- cl <- class(object)
- S3Case <- length(cl) > 1L
- if(S3Case)
- cl <- cl[[1L]]
- if(missing(class2))
- return(extends(cl))
- class1Def <- getClassDef(cl)
- if(is.null(class1Def)) # an unregistered S3 class
- return(inherits(object, class2))
- if(is.character(class2))
- class2Def <- getClassDef(class2, .classDefEnv(class1Def))
- else {
- class2Def <- class2
- class2 <- class2Def@ className
- }
- ## S3 inheritance is applied if the object is not S4 and class2 is either a basic
- ## class or an S3 class (registered or not)
- S3Case <- S3Case || (is.object(object) && !isS4(object)) # first requirement
- S3Case <- S3Case && (is.null(class2Def) || class2 %in% .BasicClasses ||
- extends(class2Def, "oldClass"))
- if(S3Case)
- return(inherits(object, class2))
- if(.identC(cl, class2) || .identC(class2, "ANY"))
- return(TRUE)
- ext <- possibleExtends(cl, class2, class1Def, class2Def)
- if(is.logical(ext))
- ext
- else if(ext@simple)
- TRUE
- else
- ext@test(object)
-}
-
-extends <-
- ## Does the first class extend the second class?
- ## Returns `maybe' if the extension includes a non-trivial test.
- function(class1, class2, maybe = TRUE, fullInfo = FALSE)
-{
- if(is.character(class1)) {
- if(length(class1) > 1L)
- class1 <- class1[[1L]]
- classDef1 <- getClassDef(class1)
- } else if(is(class1, "classRepresentation")) {
- classDef1 <- class1
- class1 <- classDef1@className
- }
- else
- stop("'class1' must be the name of a class or a class definition")
- if(missing(class2)) {
- if(is.null(classDef1))
- return(class1)
- ext <- classDef1@contains
- if(!identical(maybe, TRUE) && length(ext) > 0)
- {
- noTest <- sapply(ext, function(obj)identical(body(obj@test), TRUE))
- ext <- ext[noTest]
- }
- if(fullInfo) {
- elNamed(ext, class1) <- TRUE
- return(ext)
- }
- else
- return(c(class1,names(ext)))
- }
- value <- NULL
- if(is.character(class2) && length(class2) == 1L) { ## fast first checks
- ## the [[1L]] below handles old-style classes & throws away package attributes
- if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
- return(TRUE)
- if(!is.null(classDef1) && class2 %in% names(classDef1@contains))
- value <- classDef1@contains[[class2]]
- else
- classDef2 <- getClassDef(class2)
- }
- else if(is(class2, "classRepresentation")) {
- classDef2 <- class2
- class2 <- class2@className
- }
- else
- stop("'class2' must be the name of a class or a class definition")
- if(is.null(value))
- value <- possibleExtends(class1, class2, classDef1, classDef2)
- if(fullInfo)
- value
- else if(is.logical(value))
- value
- else if(value@simple || identical(body(value@test), TRUE))
- TRUE
- else
- maybe
-}
-
-.specialVirtual <- c("oldClass")
-
-setIs <-
- ## Defines class1 to be an extension of class2.
- ## The relationship can be conditional, if a function is supplied as the `test'
- ## argument. If a function is supplied as the `coerce' argument, this function will
- ## be applied to any `class1' object in order to turn it into a `class2' object.
- ##
- ## Extension may imply that a `class1' object contains a `class2' object. The default
- ## sense of containing is that all the slots of the simpler class are found in the
- ## more elaborate one. If the `replace' argument is supplied as an S replacement
- ## function, this function will be used to implement `as(obj, class2) <- value'.
- function(class1, class2, test = NULL, coerce = NULL,
- replace = NULL, by = character(), where = topenv(parent.frame()),
- classDef = getClass(class1, TRUE, where = where), extensionObject = NULL, doComplete = TRUE)
-{
- ## class2 should exist
- where <- as.environment(where)
- classDef2 <- getClassDef(class2, where)
- if(is.null(classDef2))
- stop(gettextf("class %s has no visible definition from package or environment %s",
- dQuote(class2),
- sQuote(getPackageName(where))),
- domain = NA)
- ## check some requirements:
- ## One of the classes must be on the target environment (so that the relation can
- ## be retained by saving the corresponding image)
- m1 <- classMetaName(class1)
- local1 <- exists(m1, where, inherits = FALSE) &&
- !(classDef@sealed || bindingIsLocked(m1, where))
- m2 <- classMetaName(class2)
- local2 <- exists(m2, where, inherits = FALSE) &&
- !(classDef2@sealed || bindingIsLocked(m2, where))
- if(!(local1 || local2) )
- stop(gettextf("cannot create a 'setIs' relation when neither of the classes (%s and %s) is local and modifiable in this package",
- dQuote(class1),
- dQuote(class2)),
- domain = NA)
- if(classDef@sealed && !isClassUnion(classDef2))
- stop(gettextf("class %s is sealed; new superclasses can not be defined, except by 'setClassUnion'",
- dQuote(class1)),
- domain = NA)
- prevIs <- !identical(possibleExtends(class1, class2,classDef, classDef2),
- FALSE) # used in checking for previous coerce
- if(is.null(extensionObject))
- obj <- makeExtends(class1, class2, coerce, test, replace, by,
- classDef1 = classDef, classDef2 = classDef2,
- package = getPackageName(where))
- else
- obj <- extensionObject
- ## revise the superclass/subclass info in the stored class definition
- ok <- .validExtends(class1, class2, classDef, classDef2, obj@simple)
- if(!identical(ok, TRUE))
- stop(ok)
- where2 <- .findOrCopyClass(class2, classDef2, where, "subclass")
- elNamed(classDef2@subclasses, class1) <- obj
- if(doComplete)
- classDef2@subclasses <- completeSubclasses(classDef2, class1, obj, where)
- ## try to provide a valid prototype for virtual classes
- if(classDef2@virtual && is.na(match(class2, .specialVirtual))) {
- ## For simplicity, we prefer NULL prototype if "NULL"
- ## is a subclass of a virtual class; otherwise the
- ## prototype is an element of class1 or its prototype if VIRTUAL
- if(extends(classDef, "NULL"))
- classDef2@prototype <- NULL
- else if(is.null(classDef2@prototype)
- && is.na(match("NULL", names(classDef2@subclasses)))) {
- if(classDef@virtual)
- classDef2@prototype <- classDef@prototype
- else # new(), but without intialize(), which may require an arg.
- classDef2@prototype <- .Call(C_new_object, classDef)
- }
- }
- assignClassDef(class2, classDef2, where2, TRUE)
- .removePreviousCoerce(class1, class2, where, prevIs)
- where1 <- .findOrCopyClass(class1, classDef, where, "superClass")
- ## insert the direct contains information in a valid spot
- .newDirectSuperclass(classDef@contains, class2, names(classDef2@contains)) <- obj
- if(doComplete) {
- classDef@contains <- completeExtends(classDef, class2, obj, where = where)
- if(!is(classDef, "ClassUnionRepresentation")) #unions are handled in assignClassDef
- .checkSubclasses(class1, classDef, class2, classDef2, where1, where2)
- }
- assignClassDef(class1, classDef, where1, TRUE)
- invisible(classDef)
-}
-
-.findOrCopyClass <- function(class, classDef, where, purpose) {
- whereIs <- findClass(classDef, where)
- if(length(whereIs))
- whereIs[[1L]]
- else {
- warning(gettextf("class %s is defined (with package slot %s) but no metadata object found to revise %s information---not exported? Making a copy in package %s",
- .dQ(class), sQuote(classDef@package), purpose,
- sQuote(getPackageName(where, FALSE))),
- call. = FALSE, domain = NA)
- where
- }
-}
-
-
-.validExtends <- function(class1, class2, classDef1, classDef2, slotTests) {
- .msg <- function(class1, class2)
- gettextf("class %s cannot extend class %s",
- dQuote(class1),
- dQuote(class2))
- if((is.null(classDef1) || is.null(classDef2)) &&
- !(isVirtualClass(class1) && isVirtualClass(class2)))
- return(c(.msg(class1, class2), ": ",
- gettext("both classes must be defined")))
- if(slotTests) {
- slots2 <- classDef2@slots
- if(length(slots2)) {
- n2 <- names(slots2)
- slots1 <- classDef1@slots
- n1 <- names(slots1)
- if(any(is.na(match(n2, n1))))
- return(c(.msg(class1, class2), ": ",
- sprintf(ngettext(sum(is.na(match(n2, n1))),
- "class %s is missing slot from class %s (%s), and no coerce method was supplied",
- "class %s is missing slots from class %s (%s), and no coerce method was supplied"),
- dQuote(class1),
- dQuote(class2),
- paste(n2[is.na(match(n2, n1))], collapse = ", "))))
- bad <- character()
- for(what in n2)
- if(!extends(elNamed(slots1, what), elNamed(slots2, what)))
- bad <- c(bad, what)
- if(length(bad))
- return(c(.msg(class1, class2), ": ",
- sprintf(ngettext(length(bad),
- "slot in class %s must extend corresponding slot in class %s: fails for %s",
- "slots in class %s must extend corresponding slots in class %s: fails for %s"),
- dQuote(class1),
- dQuote(class2),
- paste(bad, collapse = ", "))))
- }
- }
- TRUE
-}
-
-".newDirectSuperclass<-" <- function(contains, class2, superclasses2, value) {
- superclasses <- names(contains)
- if(length(superclasses2) == 0 || length(superclasses) == 0 ||
- all(is.na(match(superclasses2, superclasses))))
- elNamed(contains, class2) <- value
- else {
- sq <- seq_along(superclasses)
- before <- (sq[match(superclasses, superclasses2,0)>0])[[1]]
- contains <- c(contains[sq < before], value, contains[sq >= before])
- superclasses <- c(superclasses[sq < before], class2, superclasses[sq >= before])
- names(contains) <- superclasses
- }
- contains
-}
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/packageName.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/packageName.R
deleted file mode 100644
index 7acbd2c45c419338f88107f09dd2256bfe1686d4..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/R/packageName.R
+++ /dev/null
@@ -1,89 +0,0 @@
-# File src/library/methods/R/packageName.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-## utilities to manage package names
-
-getPackageName <- function(where = topenv(parent.frame()), create = TRUE) {
- pkg <- ""
- hasNameSaved <- exists(".packageName", where, inherits = FALSE)
- if(hasNameSaved)
- pkg <- get(".packageName", where)
- else if(identical(where, 1) || identical(as.environment(where), topenv(parent.frame())))
- pkg <- Sys.getenv("R_PACKAGE_NAME")
- env <- as.environment(where)
- envName <- environmentName(env)
- if(nzchar(envName)) {
- if(regexpr("package:", envName, fixed = TRUE) == 1L)
- pkg <- sub("package:","", envName, fixed = TRUE)
- }
- if(!nzchar(pkg)) { ## is still ""
- if(identical(env, .GlobalEnv))
- pkg <- ".GlobalEnv"
- else if(identical(env, .BaseNamespaceEnv))
- pkg <- "base"
- else {
- if(is.numeric(where))
- pkg <- search()[[where]]
- else if(is.environment(where)) {
- for(db in search())
- if(identical(as.environment(db), where)) {
- pkg <- db; break
- }
- }
- else if(nzchar(environmentName(env)))
- pkg <- environmentName(env)
- else
- pkg <- as.character(where)
- if(identical(substr(pkg, 1L, 8L), "package:"))
- pkg <- substr(pkg, 9L, nchar(pkg, "c"))
- }
-# Problem: the library() function should now be putting .packageName in package environments
-# but namespace makes them invisible from outside.
- ## save the package name, but .GlobalEnv is not a package name,
- ## and package base doesn't have a .packageName (yet?)
-# if(!(identical(pkg, ".GlobalEnv") || identical(pkg, "base")) ) {
-# setPackageName(pkg, env)
-# ## packages OUGHT
-# ## to be self-identifying
-# warning("The package name \"", pkg, "\" was inferred, but not found in that package")
-# }
- }
- if(!nzchar(pkg) && create) {
- pkg <- as.character(Sys.time())
- warning(gettextf("Created a package name, %s, when none found",
- sQuote(pkg)),
- domain = NA)
- assign(pkg, env, envir = .PackageEnvironments)
- if(!(hasNameSaved || environmentIsLocked(env)))
- setPackageName(pkg, env)
- }
- pkg
-}
-
-setPackageName <- function(pkg, env)
- assign(".packageName", pkg, envir = env)
-
-##FIXME: rather than an attribute, the className should have a formal class
-## (but there may be bootstrap problems)
-packageSlot <- function(object)
- attr(object, "package")
-
-`packageSlot<-` <- function(object, value) {
- attr(object, "package") <- value
- object
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Covcor.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Covcor.java
similarity index 96%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Covcor.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Covcor.java
index f205570ed7da6263ea422d44e6c63f6d851aada9..ca472e243689667f8523933ba890d100ed797426 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Covcor.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Covcor.java
@@ -9,10 +9,10 @@
*
* All rights reserved.
*/
-package com.oracle.truffle.r.nodes.builtin.base;
+package com.oracle.truffle.r.nodes.builtin.stats;
-import com.oracle.truffle.api.nodes.*;
-import com.oracle.truffle.r.nodes.builtin.*;
+import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
+import com.oracle.truffle.api.source.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
import com.oracle.truffle.r.runtime.ops.na.*;
@@ -20,12 +20,17 @@ import com.oracle.truffle.r.runtime.ops.na.*;
/*
* Logic derived from GNU-R, library/stats/src/cov.c
*/
-public abstract class Covcor extends RBuiltinNode {
+public class Covcor {
+ private static final Covcor singleton = new Covcor();
private final NACheck check = new NACheck();
- private final NAProfile naProfile = NAProfile.create();
- protected RDoubleVector corcov(RDoubleVector x, RDoubleVector y, boolean iskendall, boolean cor) {
+ public static Covcor getInstance() {
+ return singleton;
+ }
+
+ @TruffleBoundary
+ public RDoubleVector corcov(RDoubleVector x, RDoubleVector y, @SuppressWarnings("unused") int method, boolean iskendall, boolean cor, SourceSection src) throws RError {
boolean ansmat;
boolean naFail;
boolean everything;
@@ -97,12 +102,12 @@ public abstract class Covcor extends RBuiltinNode {
}
if (sd0) { /* only in cor() */
- RError.warning(getEncapsulatingSourceSection(), RError.Message.SD_ZERO);
+ RError.warning(src, RError.Message.SD_ZERO);
}
boolean seenNA = false;
for (int i = 0; i < answerData.length; i++) {
- if (naProfile.isNA(answerData[i])) {
+ if (RRuntime.isNA(answerData[i])) {
seenNA = true;
break;
}
@@ -638,11 +643,11 @@ public abstract class Covcor extends RBuiltinNode {
}
}
- private static void error(String string) {
+ private void error(String string) {
+ // TODO should be an R error
throw new UnsupportedOperationException("error: " + string);
}
- @ExplodeLoop
private boolean checkNAs(double... xs) {
for (double x : xs) {
check.enable(x);
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/GammaFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/GammaFunctions.java
index e8ccabaf561dec1b68473f661170e7d17a2efbcc..349f7495f3453ee704c34508dcc4f136a0e17e8a 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/GammaFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/GammaFunctions.java
@@ -8,7 +8,7 @@
* Copyright (c) 1998--2014, The R Core Team
* Copyright (c) 2002--2010, The R Foundation
* Copyright (C) 2005--2006, Morten Welinder
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates
*
* based on AS 91 (C) 1979 Royal Statistical Society
* and on AS 111 (C) 1977 Royal Statistical Society
@@ -19,18 +19,9 @@
package com.oracle.truffle.r.nodes.builtin.stats;
import static com.oracle.truffle.r.nodes.builtin.stats.StatsUtil.*;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.*;
-import com.oracle.truffle.api.CompilerDirectives.CompilationFinal;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.api.frame.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.nodes.builtin.stats.GammaFunctionsFactory.DpsiFnCalcNodeGen;
+import com.oracle.truffle.api.CompilerDirectives.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
-import com.oracle.truffle.r.runtime.data.closures.*;
import com.oracle.truffle.r.runtime.data.model.*;
import com.oracle.truffle.r.runtime.ops.*;
import com.oracle.truffle.r.runtime.ops.na.*;
@@ -39,43 +30,23 @@ import com.oracle.truffle.r.runtime.ops.na.*;
* Java implementation of the qgamma function. The logic was derived from GNU R (see inline
* comments).
*
- * The original GNU R implementation treats this as a {@code .External} call. The FastR
- * implementation, until it supports {@code .External}, treats it as an {@code .Internal}.
*/
public abstract class GammaFunctions {
// This is derived from distn.c.
- @RBuiltin(name = "qgamma", kind = INTERNAL, parameterNames = {"p", "shape", "scale", "lower.tail", "log.p"})
- public abstract static class Qgamma extends RBuiltinNode {
+ public static class Qgamma {
+
+ private static final Qgamma singleton = new Qgamma();
private final NACheck naCheck = NACheck.create();
- @Specialization(guards = "!emptyShapeOrScale")
- protected RDoubleVector qgamma(double p, RAbstractDoubleVector shape, RAbstractDoubleVector scale, byte lowerTail, byte logP) {
- controlVisibility();
- int shapeLen = shape.getLength();
- int scaleLen = scale.getLength();
- double[] result = new double[Math.max(shapeLen, scaleLen)];
- RAbstractDoubleVector attrSource = null;
- if (result.length > 1) {
- attrSource = shapeLen == result.length ? shape : scale;
- }
- naCheck.enable(true);
- for (int i = 0, j = 0, k = 0; i < result.length; i++, j = Utils.incMod(j, shapeLen), k = Utils.incMod(k, scaleLen)) {
- result[i] = GammaFunctions.qgamma(p, shape.getDataAt(j), scale.getDataAt(k), lowerTail == RRuntime.LOGICAL_TRUE, logP == RRuntime.LOGICAL_TRUE);
- naCheck.check(result[i]);
- }
- RDoubleVector res = RDataFactory.createDoubleVector(result, naCheck.neverSeenNA());
- if (attrSource != null) {
- res.copyAttributesFrom(attrSource);
- }
- return res;
+ public static Qgamma getInstance() {
+ return singleton;
}
- @Specialization(guards = "!emptyShapeOrScale")
- protected RDoubleVector qgamma(RAbstractDoubleVector p, RAbstractDoubleVector shape, RAbstractDoubleVector scale, byte lowerTail, byte logP) {
- controlVisibility();
+ @TruffleBoundary
+ public RDoubleVector qgamma(RAbstractDoubleVector p, RAbstractDoubleVector shape, RAbstractDoubleVector scale, byte lowerTail, byte logP) {
int pLen = p.getLength();
int shapeLen = shape.getLength();
int scaleLen = scale.getLength();
@@ -97,121 +68,6 @@ public abstract class GammaFunctions {
return res;
}
- @SuppressWarnings("unused")
- @Specialization(guards = "emptyShapeOrScale")
- protected RDoubleVector qgammaEmptyShapeOrScale(RAbstractDoubleVector p, RAbstractDoubleVector shape, RAbstractDoubleVector scale, byte lowerTail, byte logP) {
- return RDataFactory.createEmptyDoubleVector();
- }
-
- protected boolean emptyShapeOrScale(@SuppressWarnings("unused") Object p, RAbstractDoubleVector shape, RAbstractDoubleVector scale) {
- return shape.getLength() == 0 || scale.getLength() == 0;
- }
-
- }
-
- @RBuiltin(name = "lgamma", kind = PRIMITIVE, parameterNames = {"x"})
- public abstract static class Lgamma extends RBuiltinNode {
-
- private final NACheck naClosureCheck = NACheck.create();
- private final NACheck naValCheck = NACheck.create();
-
- @Specialization
- protected RDoubleVector lgamma(RAbstractDoubleVector x) {
- controlVisibility();
- naValCheck.enable(true);
- double[] result = new double[x.getLength()];
- for (int i = 0; i < x.getLength(); ++i) {
- double xv = x.getDataAt(i);
- result[i] = GammaFunctions.lgammafn(xv);
- naValCheck.check(result[i]);
- }
- return RDataFactory.createDoubleVector(result, naValCheck.neverSeenNA());
- }
-
- @Specialization
- protected RDoubleVector lgamma(RAbstractIntVector x) {
- return lgamma(RClosures.createIntToDoubleVector(x, naClosureCheck));
- }
-
- @Specialization
- protected RDoubleVector lgamma(RAbstractLogicalVector x) {
- return lgamma(RClosures.createLogicalToDoubleVector(x, naClosureCheck));
- }
-
- @Specialization
- protected Object lgamma(@SuppressWarnings("unused") RAbstractComplexVector x) {
- return RError.error(RError.Message.UNIMPLEMENTED_COMPLEX_FUN);
- }
-
- @Fallback
- protected Object lgamma(@SuppressWarnings("unused") Object x) {
- throw RError.error(RError.Message.NON_NUMERIC_MATH);
- }
-
- }
-
- @RBuiltin(name = "digamma", kind = PRIMITIVE, parameterNames = {"x"})
- public abstract static class DiGamma extends RBuiltinNode {
-
- @Child DpsiFnCalc dpsiFnCalc;
-
- private final NACheck naClosureCheck = NACheck.create();
- private final NACheck naValCheck = NACheck.create();
-
- private double dpsiFnCalc(VirtualFrame frame, double x, int n, int kode, double ans) {
- if (dpsiFnCalc == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- dpsiFnCalc = insert(DpsiFnCalcNodeGen.create(null, null, null, null));
- }
- return dpsiFnCalc.executeDouble(frame, x, n, kode, ans);
- }
-
- @Specialization
- protected RDoubleVector digamma(VirtualFrame frame, RAbstractDoubleVector x) {
- controlVisibility();
- naValCheck.enable(x);
- double[] result = new double[x.getLength()];
- boolean warnNaN = false;
- for (int i = 0; i < x.getLength(); ++i) {
- double xv = x.getDataAt(i);
- if (naValCheck.check(xv)) {
- result[i] = xv;
- } else {
- double val = dpsiFnCalc(frame, xv, 0, 1, 0);
- if (Double.isNaN(val)) {
- result[i] = val;
- warnNaN = true;
- } else {
- result[i] = -val;
- }
- }
- }
- if (warnNaN) {
- RError.warning(RError.Message.NAN_PRODUCED);
- }
- return RDataFactory.createDoubleVector(result, naValCheck.neverSeenNA());
- }
-
- @Specialization
- protected RDoubleVector digamma(VirtualFrame frame, RAbstractIntVector x) {
- return digamma(frame, RClosures.createIntToDoubleVector(x, naClosureCheck));
- }
-
- @Specialization
- protected RDoubleVector digamma(VirtualFrame frame, RAbstractLogicalVector x) {
- return digamma(frame, RClosures.createLogicalToDoubleVector(x, naClosureCheck));
- }
-
- @Specialization
- protected Object digamma(@SuppressWarnings("unused") RAbstractComplexVector x) {
- return RError.error(RError.Message.UNIMPLEMENTED_COMPLEX_FUN);
- }
-
- @Fallback
- protected Object digamma(@SuppressWarnings("unused") Object x) {
- throw RError.error(RError.Message.NON_NUMERIC_MATH);
- }
-
}
// The remainder of this file is derived from GNU R (mostly nmath): qgamma.c, nmath.h, lgamma.c,
@@ -571,7 +427,7 @@ public abstract class GammaFunctions {
return ans;
}
- private static double lgammafn(double x) {
+ public static double lgammafn(double x) {
return lgammafnSign(x, new int[1]);
}
@@ -621,7 +477,7 @@ public abstract class GammaFunctions {
double lgam1pa = (alpha < 0.5) ? lgamma1p(alpha) : (Math.log(alpha) + g);
ch = Math.exp((lgam1pa + p1) / alpha + M_LN2);
} else if (nu > 0.32) { /* using Wilson and Hilferty estimate */
- x = Rnorm.qnorm5(p, 0, 1, lowerTail, logp);
+ x = Random2.qnorm5(p, 0, 1, lowerTail, logp);
p1 = 2. / (9 * nu);
ch = nu * Math.pow(x * Math.sqrt(p1) + 1 - p1, 3);
@@ -803,9 +659,9 @@ public abstract class GammaFunctions {
/*
* PR# 2214 : From: Morten Welinder <terra@diku.dk>, Fri, 25 Oct 2002 16:50 -------- To:
* R-bugs@biostat.ku.dk Subject: qgamma precision
- *
+ *
* With a final Newton step, double accuracy, e.g. for (p= 7e-4; nu= 0.9)
- *
+ *
* Improved (MM): - only if rel.Err > EPS_N (= 1e-15); - also for lower_tail = FALSE or
* log_p = TRUE - optionally *iterate* Newton
*/
@@ -1715,434 +1571,4 @@ public abstract class GammaFunctions {
}
}
- @NodeChildren({@NodeChild(value = "x"), @NodeChild(value = "n"), @NodeChild(value = "kode"), @NodeChild(value = "ans")})
- protected abstract static class DpsiFnCalc extends RNode {
-
- // the following is transcribed from polygamma.c
-
- public abstract double executeDouble(VirtualFrame frame, double x, int n, int kode, double ans);
-
- @Child DpsiFnCalc dpsiFnCalc;
-
- @CompilationFinal private static final double[] bvalues = new double[]{1.00000000000000000e+00, -5.00000000000000000e-01, 1.66666666666666667e-01, -3.33333333333333333e-02,
- 2.38095238095238095e-02, -3.33333333333333333e-02, 7.57575757575757576e-02, -2.53113553113553114e-01, 1.16666666666666667e+00, -7.09215686274509804e+00,
- 5.49711779448621554e+01, -5.29124242424242424e+02, 6.19212318840579710e+03, -8.65802531135531136e+04, 1.42551716666666667e+06, -2.72982310678160920e+07,
- 6.01580873900642368e+08, -1.51163157670921569e+10, 4.29614643061166667e+11, -1.37116552050883328e+13, 4.88332318973593167e+14, -1.92965793419400681e+16};
-
- private static final int n_max = 100;
- // the following is actually a parameter in the original code, but it's always 1 and must be
- // as the original code treats the "ans" value of type double as an array, which is legal
- // only if a the first element of the array is accessed at all times
- private static final int m = 1;
-
- private double dpsiFnCalc(VirtualFrame frame, double x, int n, int kode, double ans) {
- if (dpsiFnCalc == null) {
- CompilerDirectives.transferToInterpreterAndInvalidate();
- dpsiFnCalc = insert(DpsiFnCalcNodeGen.create(null, null, null, null));
- }
- return dpsiFnCalc.executeDouble(frame, x, n, kode, ans);
- }
-
- // TODO: it's recursive - turn into AST recursion
- @Specialization
- double dpsifn(VirtualFrame frame, double xOld, int n, int kode, double ansOld) {
-
- double x = xOld;
- double ans = ansOld;
-
- int mm;
- int mx;
- int nn;
- int np;
- int nx;
- int fn;
- double arg;
- double den;
- double elim;
- double eps;
- double fln;
- double rln;
- double r1m4;
- double r1m5;
- double s;
- double slope;
- double t;
- double tk;
- double tt;
- double t1;
- double t2;
- double wdtol;
- double xdmln;
- double xdmy;
- double xinc;
- double xln = 0.0;
- double xm;
- double xmin;
- double yint;
- double[] trm = new double[23];
- double[] trmr = new double[n_max + 1];
-
- // non-zero ierr always results in generating a NaN
-// mVal.ierr = 0;
- if (n < 0 || kode < 1 || kode > 2 || m < 1) {
- return Double.NaN;
- }
- if (x <= 0.) {
- /*
- * use Abramowitz & Stegun 6.4.7 "Reflection Formula" psi(k, x) = (-1)^k psi(k, 1-x)
- * - pi^{n+1} (d/dx)^n cot(x)
- */
- if (x == Math.round(x)) {
- /* non-positive integer : +Inf or NaN depends on n */
-// for(j=0; j < m; j++) /* k = j + n : */
-// ans[j] = ((j+n) % 2) ? ML_POSINF : ML_NAN;
- // m is always 1
- ans = (n % 2) != 0 ? Double.POSITIVE_INFINITY : Double.NaN;
- return ans;
- }
- /* This could cancel badly */
- ans = dpsiFnCalc(frame, 1. - x, n, /* kode = */1, ans);
- /*
- * ans[j] == (-1)^(k+1) / gamma(k+1) * psi(k, 1 - x) for j = 0:(m-1) , k = n + j
- */
-
- /* Cheat for now: only work for m = 1, n in {0,1,2,3} : */
- if (m > 1 || n > 3) { /* doesn't happen for digamma() .. pentagamma() */
- /* not yet implemented */
- // non-zero ierr always results in generating a NaN
-// mVal.ierr = 4;
- return Double.NaN;
- }
- x *= M_PI; /* pi * x */
- if (n == 0) {
- tt = Math.cos(x) / Math.sin(x);
- } else if (n == 1) {
- tt = -1 / Math.pow(Math.sin(x), 2);
- } else if (n == 2) {
- tt = 2 * Math.cos(x) / Math.pow(Math.sin(x), 3);
- } else if (n == 3) {
- tt = -2 * (2 * Math.pow(Math.cos(x), 2) + 1.) / Math.pow(Math.sin(x), 4);
- } else { /* can not happen! */
- tt = RRuntime.DOUBLE_NA;
- }
- /* end cheat */
-
- s = (n % 2) != 0 ? -1. : 1.; /* s = (-1)^n */
- /*
- * t := pi^(n+1) * d_n(x) / gamma(n+1) , where d_n(x) := (d/dx)^n cot(x)
- */
- t1 = t2 = s = 1.;
- for (int k = 0, j = k - n; j < m; k++, j++, s = -s) {
- /* k == n+j , s = (-1)^k */
- t1 *= M_PI; /* t1 == pi^(k+1) */
- if (k >= 2) {
- t2 *= k; /* t2 == k! == gamma(k+1) */
- }
- if (j >= 0) { /* by cheat above, tt === d_k(x) */
- // j must always be 0
- assert j == 0;
-// ans[j] = s*(ans[j] + t1/t2 * tt);
- ans = s * (ans + t1 / t2 * tt);
- }
- }
- if (n == 0 && kode == 2) { /* unused from R, but "wrong": xln === 0 : */
-// ans[0] += xln;
- ans += xln;
- }
- return ans;
- } /* x <= 0 */
-
- /* else : x > 0 */
- // nz not used
-// mVal.nz = 0;
- xln = Math.log(x);
- if (kode == 1 /* && m == 1 */) { /* the R case --- for very large x: */
- double lrg = 1 / (2. * DBLEPSILON);
- if (n == 0 && x * xln > lrg) {
-// ans[0] = -xln;
- ans = -xln;
- return ans;
- } else if (n >= 1 && x > n * lrg) {
-// ans[0] = exp(-n * xln)/n; /* == x^-n / n == 1/(n * x^n) */
- ans = Math.exp(-n * xln) / n;
- return ans;
- }
- }
- mm = m;
- // nx = imin2(-Rf_i1mach(15), Rf_i1mach(16));/* = 1021 */
- nx = Math.min(-DBL_MIN_EXP, DBL_MAX_EXP);
- assert (nx == 1021);
- r1m5 = M_LOG10_2; // Rf_d1mach(5);
- r1m4 = DBLEPSILON * 0.5; // Rf_d1mach(4) * 0.5;
- wdtol = fmax2(r1m4, 0.5e-18); /* 1.11e-16 */
-
- /* elim = approximate exponential over and underflow limit */
- elim = 2.302 * (nx * r1m5 - 3.0); /* = 700.6174... */
- for (;;) {
- nn = n + mm - 1;
- fn = nn;
- t = (fn + 1) * xln;
-
- /* overflow and underflow test for small and large x */
-
- if (Math.abs(t) > elim) {
- if (t <= 0.0) {
- // nz not used
-// mVal.nz = 0;
- // non-zero ierr always results in generating a NaN
-// mVal.ierr = 2;
- return Double.NaN;
- }
- } else {
- if (x < wdtol) {
-// ans[0] = R_pow_di(x, -n-1);
- ans = Math.pow(x, -n - 1);
- if (mm != 1) {
-// for(k = 1; k < mm ; k++)
-// ans[k] = ans[k-1] / x;
- assert mm < 2;
- // int the original code, ans should not be accessed beyond the 0th
-// index
- }
- if (n == 0 && kode == 2) {
-// ans[0] += xln;
- ans += xln;
- }
- return ans;
- }
-
- /* compute xmin and the number of terms of the series, fln+1 */
-
- rln = r1m5 * DBL_MANT_DIG; // Rf_i1mach(14);
- rln = Math.min(rln, 18.06);
- fln = Math.max(rln, 3.0) - 3.0;
- yint = 3.50 + 0.40 * fln;
- slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
- xm = yint + slope * fn;
- mx = (int) xm + 1;
- xmin = mx;
- if (n != 0) {
- xm = -2.302 * rln - Math.min(0.0, xln);
- arg = xm / n;
- arg = Math.min(0.0, arg);
- eps = Math.exp(arg);
- xm = 1.0 - eps;
- if (Math.abs(arg) < 1.0e-3) {
- xm = -arg;
- }
- fln = x * xm / eps;
- xm = xmin - x;
- if (xm > 7.0 && fln < 15.0) {
- break;
- }
- }
- xdmy = x;
- xdmln = xln;
- xinc = 0.0;
- if (x < xmin) {
- nx = (int) x;
- xinc = xmin - nx;
- xdmy = x + xinc;
- xdmln = Math.log(xdmy);
- }
-
- /* generate w(n+mm-1, x) by the asymptotic expansion */
-
- t = fn * xdmln;
- t1 = xdmln + xdmln;
- t2 = t + xdmln;
- tk = Math.max(Math.abs(t), fmax2(Math.abs(t1), Math.abs(t2)));
- if (tk <= elim) { /* for all but large x */
- return l10(t, tk, xdmy, xdmln, x, nn, nx, wdtol, fn, trm, trmr, xinc, mm, kode, ans);
- }
- }
- // nz not used
-// mVal.nz++; /* underflow */
- mm--;
-// ans[mm] = 0.;
- assert mm == 0;
- ans = 0.;
- if (mm == 0) {
- return ans;
- }
- } /* end{for()} */
- nn = (int) fln + 1;
- np = n + 1;
- t1 = (n + 1) * xln;
- t = Math.exp(-t1);
- s = t;
- den = x;
- for (int i = 1; i <= nn; i++) {
- den += 1.;
- trm[i] = Math.pow(den, -np);
- s += trm[i];
- }
-// ans[0] = s;
- ans = s;
- if (n == 0 && kode == 2) {
-// ans[0] = s + xln;
- ans = s + xln;
- }
-
- if (mm != 1) { /* generate higher derivatives, j > n */
- assert false;
-// tol = wdtol / 5.0;
-// for(j = 1; j < mm; j++) {
-// t /= x;
-// s = t;
-// tols = t * tol;
-// den = x;
-// for(i=1; i <= nn; i++) {
-// den += 1.;
-// trm[i] /= den;
-// s += trm[i];
-// if (trm[i] < tols) {
-// break;
-// }
-// }
-// ans[j] = s;
-// }
- }
- return ans;
-
- }
-
- private static double l10(double oldT, double oldTk, double xdmy, double xdmln, double x, double nn, double oldNx, double wdtol, double oldFn, double[] trm, double[] trmr, double xinc,
- double mm, int kode, double ansOld) {
- double t = oldT;
- double tk = oldTk;
- double nx = oldNx;
- double fn = oldFn;
- double ans = ansOld;
-
- double tss = Math.exp(-t);
- double tt = 0.5 / xdmy;
- double t1 = tt;
- double tst = wdtol * tt;
- if (nn != 0) {
- t1 = tt + 1.0 / fn;
- }
- double rxsq = 1.0 / (xdmy * xdmy);
- double ta = 0.5 * rxsq;
- t = (fn + 1) * ta;
- double s = t * bvalues[2];
- if (Math.abs(s) >= tst) {
- tk = 2.0;
- for (int k = 4; k <= 22; k++) {
- t = t * ((tk + fn + 1) / (tk + 1.0)) * ((tk + fn) / (tk + 2.0)) * rxsq;
- trm[k] = t * bvalues[k - 1];
- if (Math.abs(trm[k]) < tst) {
- break;
- }
- s += trm[k];
- tk += 2.;
- }
- }
- s = (s + t1) * tss;
- if (xinc != 0.0) {
-
- /* backward recur from xdmy to x */
-
- nx = (int) xinc;
- double np = nn + 1;
- if (nx > n_max) {
- // nz not used
-// mVal.nz = 0;
- // non-zero ierr always results in generating a NaN
-// mVal.ierr = 3;
- return Double.NaN;
- } else {
- if (nn == 0) {
- return l20(xdmln, xdmy, x, s, nx, kode, ans);
- }
- double xm = xinc - 1.0;
- double fx = x + xm;
-
- /* this loop should not be changed. fx is accurate when x is small */
- for (int i = 1; i <= nx; i++) {
- trmr[i] = Math.pow(fx, -np);
- s += trmr[i];
- xm -= 1.;
- fx = x + xm;
- }
- }
- }
-// ans[mm-1] = s;
- assert (mm - 1) == 0;
- ans = s;
- if (fn == 0) {
- return l30(xdmln, xdmy, x, s, kode, ans);
- }
-
- /* generate lower derivatives, j < n+mm-1 */
-
- for (int j = 2; j <= mm; j++) {
- fn--;
- tss *= xdmy;
- t1 = tt;
- if (fn != 0) {
- t1 = tt + 1.0 / fn;
- }
- t = (fn + 1) * ta;
- s = t * bvalues[2];
- if (Math.abs(s) >= tst) {
- tk = 4 + fn;
- for (int k = 4; k <= 22; k++) {
- trm[k] = trm[k] * (fn + 1) / tk;
- if (Math.abs(trm[k]) < tst) {
- break;
- }
- s += trm[k];
- tk += 2.;
- }
- }
- s = (s + t1) * tss;
- if (xinc != 0.0) {
- if (fn == 0) {
- return l20(xdmln, xdmy, x, s, nx, kode, ans);
- }
- double xm = xinc - 1.0;
- double fx = x + xm;
- for (int i = 1; i <= nx; i++) {
- trmr[i] = trmr[i] * fx;
- s += trmr[i];
- xm -= 1.;
- fx = x + xm;
- }
- }
-// ans[mm - j] = s;
- assert (mm - j) == 0;
- ans = s;
- if (fn == 0) {
- return l30(xdmln, xdmy, x, s, kode, ans);
- }
- }
- return ans;
-
- }
-
- private static double l20(double xdmln, double xdmy, double x, double oldS, double nx, int kode, double ans) {
- double s = oldS;
- for (int i = 1; i <= nx; i++) {
- s += 1. / (x + (nx - i)); /* avoid disastrous cancellation, PR#13714 */
- }
-
- return l30(xdmln, xdmy, x, s, kode, ans);
- }
-
- private static double l30(double xdmln, double xdmy, double x, double s, int kode, double ansOld) {
- double ans = ansOld;
- if (kode != 2) { /* always */
-// ans[0] = s - xdmln;
- ans = s - xdmln;
- } else if (xdmy != x) {
- double xq;
- xq = xdmy / x;
-// ans[0] = s - log(xq);
- ans = s - Math.log(xq);
- }
- return ans;
- }
- }
-
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R
deleted file mode 100644
index f2760745e5fa6432c280d372c1240856c605e399..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/approx.R
+++ /dev/null
@@ -1,122 +0,0 @@
-# File src/library/stats/R/approx.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-### approx() and approxfun() are *very similar* -- keep in sync!
-
-## This function is used in approx, approxfun, spline, and splinefun
-## to massage the input (x,y) pairs into standard form:
-## x values unique and increasing, y values collapsed to match
-## (except if ties=="ordered", then not unique)
-
-regularize.values <- function(x, y, ties) {
- x <- xy.coords(x, y) # -> (x,y) numeric of same length
- y <- x$y
- x <- x$x
- if(any(na <- is.na(x) | is.na(y))) {
- ok <- !na
- x <- x[ok]
- y <- y[ok]
- }
- nx <- length(x)
- if (!identical(ties, "ordered")) {
- o <- order(x)
- x <- x[o]
- y <- y[o]
- if (length(ux <- unique(x)) < nx) {
- if (missing(ties))
- warning("collapsing to unique 'x' values")
- # tapply bases its uniqueness judgement on character representations;
- # we want to use values (PR#14377)
- y <- as.vector(tapply(y,match(x,x),ties))# as.v: drop dim & dimn.
- x <- ux
- stopifnot(length(y) == length(x))# (did happen in 2.9.0-2.11.x)
- }
- }
- list(x=x, y=y)
-}
-
-approx <- function(x, y = NULL, xout, method = "linear", n = 50,
- yleft, yright, rule = 1, f = 0, ties = mean)
-{
- method <- pmatch(method, c("linear", "constant"))
- if (is.na(method)) stop("invalid interpolation method")
- stopifnot(is.numeric(rule), (lenR <- length(rule)) >= 1L, lenR <= 2L)
- if(lenR == 1) rule <- rule[c(1,1)]
- x <- regularize.values(x, y, ties) # -> (x,y) numeric of same length
- y <- x$y
- x <- x$x
- nx <- as.integer(length(x))
- if (is.na(nx)) stop("invalid length(x)")
- if (nx <= 1) {
- if(method == 1)# linear
- stop("need at least two non-NA values to interpolate")
- if(nx == 0) stop("zero non-NA points")
- }
-
- if (missing(yleft))
- yleft <- if (rule[1L] == 1) NA else y[1L]
- if (missing(yright))
- yright <- if (rule[2L] == 1) NA else y[length(y)]
- stopifnot(length(yleft) == 1L, length(yright) == 1L, length(f) == 1L)
- if (missing(xout)) {
- if (n <= 0) stop("'approx' requires n >= 1")
- xout <- seq.int(x[1L], x[nx], length.out = n)
- }
- x <- as.double(x); y <- as.double(y)
- .Call(C_ApproxTest, x, y, method, f)
- yout <- .Call(C_Approx, x, y, xout, method, yleft, yright, f)
- list(x = xout, y = yout)
-}
-
-approxfun <- function(x, y = NULL, method = "linear",
- yleft, yright, rule = 1, f = 0, ties = mean)
-{
- method <- pmatch(method, c("linear", "constant"))
- if (is.na(method)) stop("invalid interpolation method")
- stopifnot(is.numeric(rule), (lenR <- length(rule)) >= 1L, lenR <= 2L)
- if(lenR == 1) rule <- rule[c(1,1)]
- x <- regularize.values(x, y, ties) # -> (x,y) numeric of same length
- y <- x$y
- x <- x$x
- n <- as.integer(length(x))
- if (is.na(n)) stop("invalid length(x)")
-
- if (n <= 1) {
- if(method == 1)# linear
- stop("need at least two non-NA values to interpolate")
- if(n == 0) stop("zero non-NA points")
- }
- if (missing(yleft))
- yleft <- if (rule[1L] == 1) NA else y[1L]
- if (missing(yright))
- yright <- if (rule[2L] == 1) NA else y[length(y)]
- force(f)
- stopifnot(length(yleft) == 1L, length(yright) == 1L, length(f) == 1L)
- rm(rule, ties, lenR, n) # we do not need n, but summary.stepfun did.
-
- ## 1. Test input consistency once
- x <- as.double(x); y <- as.double(y)
- .Call(C_ApproxTest, x, y, method, f)
-
- ## 2. Create and return function that does not test input validity...
- function(v) .approxfun(x, y, v, method, yleft, yright, f)
-}
-
-## avoid capturing internal calls
-.approxfun <- function(x, y, v, method, yleft, yright, f)
- .Call(C_Approx, x, y, v, method, yleft, yright, f)
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/distn.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/distn.R
deleted file mode 100644
index 6ab4e859d2217c37d59e709bde34da99d15821eb..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/distn.R
+++ /dev/null
@@ -1,333 +0,0 @@
-# File src/library/stats/R/distn.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-
-#dexp <- function(x, rate=1, log = FALSE) .External(C_dexp, x, 1/rate, log)
-#pexp <- function(q, rate=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pexp, q, 1/rate, lower.tail, log.p)
-#qexp <- function(p, rate=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qexp, p, 1/rate, lower.tail, log.p)
-#rexp <- function(n, rate=1) .External(C_rexp, n, 1/rate)
-
-#dunif <- function(x, min=0, max=1, log = FALSE)
-# .External(C_dunif, x, min, max, log)
-#punif <- function(q, min=0, max=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_punif, q, min, max, lower.tail, log.p)
-#qunif <- function(p, min=0, max=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qunif, p, min, max, lower.tail, log.p)
-#runif <- function(n, min=0, max=1) .External(C_runif, n, min, max)
-
-#dnorm <- function(x, mean=0, sd=1, log=FALSE)
-# .External(C_dnorm, x, mean, sd, log)
-#pnorm <- function(q, mean=0, sd=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pnorm, q, mean, sd, lower.tail, log.p)
-#qnorm <- function(p, mean=0, sd=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qnorm, p, mean, sd, lower.tail, log.p)
-#rnorm <- function(n, mean=0, sd=1) .External(C_rnorm, n, mean, sd)
-
-#dcauchy <- function(x, location=0, scale=1, log = FALSE)
-# .External(C_dcauchy, x, location, scale, log)
-#pcauchy <-
-# function(q, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pcauchy, q, location, scale, lower.tail, log.p)
-#qcauchy <-
-# function(p, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qcauchy, p, location, scale, lower.tail, log.p)
-#rcauchy <-
-# function(n, location=0, scale=1) .External(C_rcauchy, n, location, scale)
-
-## allow a fuzz of ca 20ulp here.
-#dgamma <- function(x, shape, rate = 1, scale = 1/rate, log = FALSE)
-#{
-# if(!missing(rate) && !missing(scale)) {
-# if(abs(rate*scale - 1) < 1e-15)
-# warning("specify 'rate' or 'scale' but not both")
-# else
-# stop("specify 'rate' or 'scale' but not both")
-# }
-# .External(C_dgamma, x, shape, scale, log)
-#}
-#pgamma <- function(q, shape, rate = 1, scale = 1/rate,
-# lower.tail = TRUE, log.p = FALSE)
-#{
-# if(!missing(rate) && !missing(scale)) {
-# if(abs(rate*scale - 1) < 1e-15)
-# warning("specify 'rate' or 'scale' but not both")
-# else
-# stop("specify 'rate' or 'scale' but not both")
-# }
-# .External(C_pgamma, q, shape, scale, lower.tail, log.p)
-#}
-qgamma <- function(p, shape, rate = 1, scale = 1/rate,
- lower.tail = TRUE, log.p = FALSE)
-{
- if(!missing(rate) && !missing(scale)) {
- if(abs(rate*scale - 1) < 1e-15)
- warning("specify 'rate' or 'scale' but not both")
- else
- stop("specify 'rate' or 'scale' but not both")
- }
- # In FastR, we treat this as an .Internal call as long as .External is not supported.
- #.External(C_qgamma, p, shape, scale, lower.tail, log.p)
- .Internal(qgamma(p, shape, scale, lower.tail, log.p))
-}
-#rgamma <- function(n, shape, rate = 1, scale = 1/rate)
-#{
-# if(!missing(rate) && !missing(scale)) {
-# if(abs(rate*scale - 1) < 1e-15)
-# warning("specify 'rate' or 'scale' but not both")
-# else
-# stop("specify 'rate' or 'scale' but not both")
-# }
-# .External(C_rgamma, n, shape, scale)
-#}
-#dlnorm <- function(x, meanlog=0, sdlog=1, log=FALSE)
-# .External(C_dlnorm, x, meanlog, sdlog, log)
-#plnorm <- function(q, meanlog=0, sdlog=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_plnorm, q, meanlog, sdlog, lower.tail, log.p)
-#qlnorm <- function(p, meanlog=0, sdlog=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qlnorm, p, meanlog, sdlog, lower.tail, log.p)
-#rlnorm <- function(n, meanlog=0, sdlog=1)
-# .External(C_rlnorm, n, meanlog, sdlog)
-
-#dlogis <- function(x, location=0, scale=1, log = FALSE)
-# .External(C_dlogis, x, location, scale, log)
-#plogis <- function(q, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_plogis, q, location, scale, lower.tail, log.p)
-#qlogis <- function(p, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qlogis, p, location, scale, lower.tail, log.p)
-#rlogis <- function(n, location=0, scale=1)
-# .External(C_rlogis, n, location, scale)
-
-#dweibull <- function(x, shape, scale=1, log = FALSE)
-# .External(C_dweibull, x, shape, scale, log)
-#pweibull <- function(q, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pweibull, q, shape, scale, lower.tail, log.p)
-#qweibull <- function(p, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qweibull, p, shape, scale, lower.tail, log.p)
-#rweibull <- function(n, shape, scale=1) .External(C_rweibull, n, shape, scale)
-
-#dbeta <- function(x, shape1, shape2, ncp=0, log = FALSE) {
-# if(missing(ncp)) .External(C_dbeta, x, shape1, shape2, log)
-# else .External(C_dnbeta, x, shape1, shape2, ncp, log)
-#}
-#pbeta <- function(q, shape1, shape2, ncp=0, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_pbeta, q, shape1, shape2, lower.tail, log.p)
-# else .External(C_pnbeta, q, shape1, shape2, ncp, lower.tail, log.p)
-#}
-#qbeta <- function(p, shape1, shape2, ncp=0, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_qbeta, p, shape1, shape2, lower.tail, log.p)
-# else .External(C_qnbeta, p, shape1, shape2, ncp, lower.tail, log.p)
-#}
-#rbeta <- function(n, shape1, shape2, ncp = 0) {
-# if(ncp == 0) .External(C_rbeta, n, shape1, shape2)
-# else {
-# X <- rchisq(n, 2*shape1, ncp =ncp)
-# X/(X + rchisq(n, 2*shape2))
-# }
-#}
-
-#dbinom <- function(x, size, prob, log = FALSE)
-# .External(C_dbinom, x, size, prob, log)
-#pbinom <- function(q, size, prob, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pbinom, q, size, prob, lower.tail, log.p)
-#qbinom <- function(p, size, prob, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qbinom, p, size, prob, lower.tail, log.p)
-#rbinom <- function(n, size, prob) .External(C_rbinom, n, size, prob)
-
-## Multivariate: that's why there's no C interface (yet) for d...():
-#dmultinom <- function(x, size=NULL, prob, log = FALSE)
-#{
-# K <- length(prob)
-# if(length(x) != K) stop("x[] and prob[] must be equal length vectors.")
-# if(any(prob < 0) || (s <- sum(prob)) == 0)
-# stop("probabilities cannot be negative nor all 0")
-# prob <- prob / s
-#
-# x <- as.integer(x + 0.5)
-# if(any(x < 0)) stop("'x' must be non-negative")
-# N <- sum(x)
-# if(is.null(size)) size <- N
-# else if (size != N) stop("size != sum(x), i.e. one is wrong")
-#
-# i0 <- prob == 0
-# if(any(i0)) {
-# if(any(x[i0] != 0))
-# ## prob[j] ==0 and x[j] > 0 ==> "impossible" => P = 0
-# return(if(log)-Inf else 0)
-# ## otherwise : 'all is fine': prob[j]= 0 = x[j] ==> drop j and continue
-# if(all(i0)) return(if(log)0 else 1)
-# ## else
-# x <- x[!i0]
-# prob <- prob[!i0]
-# }
-# r <- lgamma(size+1) + sum(x*log(prob) - lgamma(x+1))
-# if(log) r else exp(r)
-#}
-#rmultinom <- function(n, size, prob) .External(C_rmultinom, n, size, prob)
-
-#dchisq <- function(x, df, ncp=0, log = FALSE) {
-# if(missing(ncp)) .External(C_dchisq, x, df, log)
-# else .External(C_dnchisq, x, df, ncp, log)
-#}
-#pchisq <- function(q, df, ncp=0, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_pchisq, q, df, lower.tail, log.p)
-# else .External(C_pnchisq, q, df, ncp, lower.tail, log.p)
-#}
-#qchisq <- function(p, df, ncp=0, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_qchisq, p, df, lower.tail, log.p)
-# else .External(C_qnchisq, p, df, ncp, lower.tail, log.p)
-#}
-#rchisq <- function(n, df, ncp=0) {
-# if(missing(ncp)) .External(C_rchisq, n, df)
-# else .External(C_rnchisq, n, df, ncp)
-#}
-
-#df <- function(x, df1, df2, ncp, log = FALSE) {
-# if(missing(ncp)) .External(C_df, x, df1, df2, log)
-# else .External(C_dnf, x, df1, df2, ncp, log)
-#}
-#pf <- function(q, df1, df2, ncp, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_pf, q, df1, df2, lower.tail, log.p)
-# else .External(C_pnf, q, df1, df2, ncp, lower.tail, log.p)
-#}
-#qf <- function(p, df1, df2, ncp, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_qf, p, df1, df2, lower.tail, log.p)
-# else .External(C_qnf, p, df1, df2, ncp, lower.tail, log.p)
-#}
-#rf <- function(n, df1, df2, ncp)
-#{
-# if(missing(ncp)) .External(C_rf, n, df1, df2)
-# else (rchisq(n, df1, ncp=ncp)/df1)/(rchisq(n, df2)/df2)
-#}
-
-#dgeom <- function(x, prob, log = FALSE) .External(C_dgeom, x, prob, log)
-#pgeom <- function(q, prob, lower.tail = TRUE, log.p = FALSE)
-# .External(C_pgeom, q, prob, lower.tail, log.p)
-#qgeom <- function(p, prob, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qgeom, p, prob, lower.tail, log.p)
-#rgeom <- function(n, prob) .External(C_rgeom, n, prob)
-
-#dhyper <- function(x, m, n, k, log = FALSE)
-# .External(C_dhyper, x, m, n, k, log)
-#phyper <- function(q, m, n, k, lower.tail = TRUE, log.p = FALSE)
-# .External(C_phyper, q, m, n, k, lower.tail, log.p)
-#qhyper <- function(p, m, n, k, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qhyper, p, m, n, k, lower.tail, log.p)
-#rhyper <- function(nn, m, n, k) .External(C_rhyper, nn, m, n, k)
-
-#dnbinom <- function(x, size, prob, mu, log = FALSE)
-#{
-# if (!missing(mu)) {
-# if (!missing(prob)) stop("'prob' and 'mu' both specified")
-# .External(C_dnbinom_mu, x, size, mu, log)
-# }
-# else
-# .External(C_dnbinom, x, size, prob, log)
-#}
-#pnbinom <- function(q, size, prob, mu, lower.tail = TRUE, log.p = FALSE)
-#{
-# if (!missing(mu)) {
-# if (!missing(prob)) stop("'prob' and 'mu' both specified")
-# .External(C_pnbinom_mu, q, size, mu, lower.tail, log.p)
-# }
-# else
-# .External(C_pnbinom, q, size, prob, lower.tail, log.p)
-#}
-#qnbinom <- function(p, size, prob, mu, lower.tail = TRUE, log.p = FALSE)
-#{
-# if (!missing(mu)) {
-# if (!missing(prob)) stop("'prob' and 'mu' both specified")
-# ### FIXME: implement qnbinom_mu(...) properly
-# prob <- size/(size + mu)
-# }
-# .External(C_qnbinom, p, size, prob, lower.tail, log.p)
-#}
-#rnbinom <- function(n, size, prob, mu)
-#{
-# if (!missing(mu)) {
-# if (!missing(prob)) stop("'prob' and 'mu' both specified")
-# .External(C_rnbinom_mu, n, size, mu)
-# } else .External(C_rnbinom, n, size, prob)
-#}
-
-#dpois <- function(x, lambda, log = FALSE) .External(C_dpois, x, lambda, log)
-#ppois <- function(q, lambda, lower.tail = TRUE, log.p = FALSE)
-# .External(C_ppois, q, lambda, lower.tail, log.p)
-#qpois <- function(p, lambda, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qpois, p, lambda, lower.tail, log.p)
-#rpois <- function(n, lambda) .External(C_rpois, n, lambda)
-
-#dt <- function(x, df, ncp, log = FALSE) {
-# if(missing(ncp)) .External(C_dt, x, df, log)
-# else .External(C_dnt, x, df, ncp, log)
-#}
-#pt <- function(q, df, ncp, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_pt, q, df, lower.tail, log.p)
-# else .External(C_pnt, q, df, ncp, lower.tail, log.p)
-#}
-#qt <- function(p, df, ncp, lower.tail = TRUE, log.p = FALSE) {
-# if(missing(ncp)) .External(C_qt, p, df, lower.tail, log.p)
-# else .External(C_qnt,p, df, ncp, lower.tail, log.p)
-#}
-#rt <- function(n, df, ncp) {
-# if(missing(ncp)) .External(C_rt, n, df)
-# else rnorm(n, ncp)/sqrt(rchisq(n, df)/df)
-#}
-
-#ptukey <- function(q, nmeans, df, nranges=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_ptukey, q, nranges, nmeans, df, lower.tail, log.p)
-#qtukey <- function(p, nmeans, df, nranges=1, lower.tail = TRUE, log.p = FALSE)
-# .External(C_qtukey, p, nranges, nmeans, df, lower.tail, log.p)
-
-#dwilcox <- function(x, m, n, log = FALSE)
-#{
-# on.exit(.External(C_wilcox_free))
-# .External(C_dwilcox, x, m, n, log)
-#}
-#pwilcox <- function(q, m, n, lower.tail = TRUE, log.p = FALSE)
-#{
-# on.exit(.External(C_wilcox_free))
-# .External(C_pwilcox, q, m, n, lower.tail, log.p)
-#}
-#qwilcox <- function(p, m, n, lower.tail = TRUE, log.p = FALSE)
-#{
-# on.exit(.External(C_wilcox_free))
-# .External(C_qwilcox, p, m, n, lower.tail, log.p)
-#}
-#rwilcox <- function(nn, m, n) .External(C_rwilcox, nn, m, n)
-
-#dsignrank <- function(x, n, log = FALSE)
-#{
-# on.exit(.External(C_signrank_free))
-# .External(C_dsignrank, x, n, log)
-#}
-#psignrank <- function(q, n, lower.tail = TRUE, log.p = FALSE)
-#{
-# on.exit(.External(C_signrank_free))
-# .External(C_psignrank, q, n, lower.tail, log.p)
-#}
-#qsignrank <- function(p, n, lower.tail = TRUE, log.p = FALSE)
-#{
-# on.exit(.External(C_signrank_free))
-# .External(C_qsignrank, p, n, lower.tail, log.p)
-#}
-#rsignrank <- function(nn, n) .External(C_rsignrank, nn, n)
-
-##' Random sample from a Wishart distribution
-#rWishart <- function(n, df, Sigma) .Call(C_rWishart, n, df, Sigma)
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/fft.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/fft.R
deleted file mode 100644
index 7179a359bbbae9272dcee9e934a95a6c4edfae2a..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/fft.R
+++ /dev/null
@@ -1,47 +0,0 @@
-# File src/library/stats/R/fft.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-fft <- function(z, inverse=FALSE) .Call(C_fft, z, inverse)
-
-mvfft <- function(z, inverse=FALSE) .Call(C_mvfft, z, inverse)
-
-nextn <- function(n, factors=c(2,3,5)) .Call(C_nextn, n, factors)
-
-convolve <- function(x, y, conj=TRUE, type=c("circular","open","filter"))
-{
- type <- match.arg(type)
- n <- length(x)
- ny <- length(y)
- Real <- is.numeric(x) && is.numeric(y)
- ## switch(type, circular = ..., )
- if(type == "circular") {
- if(ny != n)
- stop("length mismatch in convolution")
- }
- else { ## "open" or "filter": Pad with zeros
- n1 <- ny - 1
- x <- c(rep.int(0, n1), x)
- n <- length(y <- c(y, rep.int(0, n - 1)))# n = nx+ny-1
- }
- x <- fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inverse=TRUE)
- if(type == "filter")
- (if(Real) Re(x) else x)[-c(1L:n1, (n-n1+1L):n)]/n
- else
- (if(Real) Re(x) else x)/n
-}
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/package-info.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/package-info.java
deleted file mode 100644
index 5dffae0603a1a0a691e7ed4a71dcf4401984da4d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/package-info.java
+++ /dev/null
@@ -1,29 +0,0 @@
-/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * This code is free software; you can redistribute it and/or modify it
- * under the terms of the GNU General Public License version 2 only, as
- * published by the Free Software Foundation.
- *
- * This code is distributed in the hope that it will be useful, but WITHOUT
- * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- * version 2 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 2 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-/**
- * This "package" contains R sources that correspond to (some of) the R functions
- * in the "stats" package. They are loaded using the {@link java.lang.Class#getResource}
- * mechanism on system startup.
- */
-package com.oracle.truffle.r.nodes.builtin.stats.R;
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/spline.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/spline.R
deleted file mode 100644
index c332bb82ceac75c7fa53f847d64b581c0e415628..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/spline.R
+++ /dev/null
@@ -1,105 +0,0 @@
-# File src/library/stats/R/spline.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-# 2002 Simon N. Wood
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-#### 'spline' and 'splinefun' are very similar --- keep in sync!
-#### --------- has more
-#### also consider ``compatibility'' with 'approx' and 'approxfun'
-
-spline <-
- function(x, y = NULL, n = 3*length(x), method = "fmm",
- xmin = min(x), xmax = max(x), xout, ties = mean)
-{
- method <- pmatch(method, c("periodic", "natural", "fmm", "hyman"))
- if(is.na(method)) stop("invalid interpolation method")
-
- x <- regularize.values(x, y, ties) # -> (x,y) numeric of same length
- y <- x$y
- x <- x$x
- nx <- as.integer(length(x))
- if(is.na(nx)) stop("invalid value of length(x)")
-
- if(nx == 0) stop("zero non-NA points")
-
- if(method == 1L && y[1L] != y[nx]) { # periodic
- warning("spline: first and last y values differ - using y[1] for both")
- y[nx] <- y[1L]
- }
- if(method == 4L) {
- dy <- diff(y)
- if(!(all(dy >= 0) || all(dy <= 0)))
- stop("'y' must be increasing or decreasing")
- }
-
- if(missing(xout)) xout <- seq.int(xmin, xmax, length.out = n)
- else n <- length(xout)
- if (n <= 0L) stop("'spline' requires n >= 1")
- xout <- as.double(xout)
-
- ## FastR treats C_SplineCoef as a substitute
- #z <- .Call(C_SplineCoef, min(3L, method), x, y)
- z <- SplineCoef(min(3L, method), x, y)
- if(method == 4L) z <- spl_coef_conv(hyman_filter(z))
- ## FastR treats C_SplineEval as a substitute
- #list(x = xout, y = .Call(C_SplineEval, xout, z))
- list(x = xout, y = SplineEval(xout, z))
-}
-
-### Filters cubic spline function to yield co-monotonicity in accordance
-### with Hyman (1983) SIAM J. Sci. Stat. Comput. 4(4):645-654, z$x is knot
-### position z$y is value at knot z$b is gradient at knot. See also
-### Dougherty, Edelman and Hyman 1989 Mathematics of Computation 52:471-494.
-### Contributed by Simon N. Wood, improved by R-core.
-### https://stat.ethz.ch/pipermail/r-help/2002-September/024890.html
-hyman_filter <- function(z)
-{
- n <- length(z$x)
- ss <- diff(z$y) / diff(z$x)
- S0 <- c(ss[1L], ss)
- S1 <- c(ss, ss[n-1L])
- t1 <- pmin(abs(S0), abs(S1))
- sig <- z$b
- ind <- S0*S1 > 0
- sig[ind] <- S1[ind]
- ind <- sig >= 0
- if(sum(ind)) z$b[ind] <- pmin(pmax(0, z$b[ind]), 3*t1[ind])
- ind <- !ind
- if(sum(ind)) z$b[ind] <- pmax(pmin(0, z$b[ind]), -3*t1[ind])
- z
-}
-
-
-### Takes an object z containing equal-length vectors
-### z$x, z$y, z$b, z$c, z$d defining a cubic spline interpolating
-### z$x, z$y and forces z$c and z$d to be consistent with z$y and
-### z$b (gradient of spline). This is intended for use in conjunction
-### with Hyman's monotonicity filter.
-### Note that R's spline routine has s''(x)/2 as c and s'''(x)/6 as d.
-### Contributed by Simon N. Wood, improved by R-core.
-spl_coef_conv <- function(z)
-{
- n <- length(z$x)
- h <- diff(z$x); y <- -diff(z$y)
- b0 <- z$b[-n]; b1 <- z$b[-1L]
- cc <- -(3*y + (2*b0 + b1)*h) / h^2
- c1 <- (3*y[n-1L] + (b0[n-1L] + 2*b1[n-1L])*h[n-1L]) / h[n-1L]^2
- z$c <- c(cc, c1)
- dd <- (2*y/h + b0 + b1) / h^2
- z$d <- c(dd, dd[n-1L])
- z
-}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/xyz.coords.R b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/xyz.coords.R
deleted file mode 100644
index a00706eae0ac0ac2b6d7a15f16a9f0b1b0e61e10..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/R/xyz.coords.R
+++ /dev/null
@@ -1,247 +0,0 @@
-# File src/library/grDevices/R/xyz.coords.R
-# Part of the R package, http://www.R-project.org
-#
-# Copyright (C) 1995-2012 The R Core Team
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-## Both xy.coords() and xyz.coords() --- should be kept in sync!
-
-### In FastR, this file is temporarily stored in the stats package.
-
-xy.coords <-
- function(x, y=NULL, xlab=NULL, ylab=NULL, log=NULL, recycle = FALSE)
-{
- if(is.null(y)) {
- ylab <- xlab
- if(is.language(x)) {
- if (inherits(x, "formula") && length(x) == 3) {
- ylab <- deparse(x[[2L]])
- xlab <- deparse(x[[3L]])
- y <- eval(x[[2L]], environment(x), parent.frame())
- x <- eval(x[[3L]], environment(x), parent.frame())
- }
- else stop("invalid first argument")
- }
- else if(inherits(x, "ts")) {
- y <- if(is.matrix(x)) x[,1] else x
- x <- stats::time(x)
- xlab <- "Time"
- }
- else if(is.complex(x)) {
- y <- Im(x)
- x <- Re(x)
- xlab <- paste0("Re(", ylab, ")")
- ylab <- paste0("Im(", ylab, ")")
- }
- else if(is.matrix(x) || is.data.frame(x)) {
- x <- data.matrix(x)
- if(ncol(x) == 1) {
- xlab <- "Index"
- y <- x[,1]
- x <- seq_along(y)
- }
- else {
- colnames <- dimnames(x)[[2L]]
- if(is.null(colnames)) {
- xlab <- paste0(ylab, "[,1]")
- ylab <- paste0(ylab, "[,2]")
- }
- else {
- xlab <- colnames[1L]
- ylab <- colnames[2L]
- }
- y <- x[,2]
- x <- x[,1]
- }
- }
- else if(is.list(x)) {
- if (all(c("x", "y") %in% names(x))) {
- xlab <- paste0(ylab, "$x")
- ylab <- paste0(ylab, "$y")
- y <- x[["y"]]
- x <- x[["x"]]
- } else
- stop("'x' is a list, but does not have components 'x' and 'y'")
- }
- else {
- if(is.factor(x)) x <- as.numeric(x)
- xlab <- "Index"
- y <- x
- x <- seq_along(x)
- }
- }
- ## to allow e.g. lines, points, identify to be used with plot.POSIXlt
- if(inherits(x, "POSIXt")) x <- as.POSIXct(x)
-
- if(length(x) != length(y)) {
- if(recycle) {
- if((nx <- length(x)) < (ny <- length(y)))
- x <- rep_len(x, ny)
- else
- y <- rep_len(y, nx)
- }
- else
- stop("'x' and 'y' lengths differ")
- }
-
- if(length(log) && log != "") {
- log <- strsplit(log, NULL)[[1L]]
- if("x" %in% log && any(ii <- x <= 0 & !is.na(x))) {
- n <- as.integer(sum(ii))
- warning(sprintf(ngettext(n,
- "%d x value <= 0 omitted from logarithmic plot",
- "%d x values <= 0 omitted from logarithmic plot"),
- n), domain = NA)
- x[ii] <- NA
- }
- if("y" %in% log && any(ii <- y <= 0 & !is.na(y))) {
- n <- as.integer(sum(ii))
- warning(sprintf(ngettext(n,
- "%d y value <= 0 omitted from logarithmic plot",
- "%d y values <= 0 omitted from logarithmic plot"),
- n), domain = NA)
- y[ii] <- NA
- }
- }
- return(list(x=as.double(x), y=as.double(y), xlab=xlab, ylab=ylab))
-}
-
-#xyz.coords <- function(x, y=NULL, z=NULL, xlab=NULL, ylab=NULL, zlab=NULL,
-# log = NULL, recycle = FALSE)
-#{
-# ## Only x
-# if(is.null(y)) {
-# if (is.language(x)) {
-# if (inherits(x, "formula") && length(x) == 3
-# && length(rhs <- x[[3L]]) == 3) {
-# zlab <- deparse(x[[2L]])
-# ylab <- deparse(rhs[[3L]])
-# xlab <- deparse(rhs[[2L]])
-# pf <- parent.frame()
-# z <- eval(x[[2L]], environment(x), pf)
-# y <- eval(rhs[[3L]], environment(x), pf)
-# x <- eval(rhs[[2L]], environment(x), pf)
-# }
-# else stop("invalid first argument [bad language object]")
-# }
-# else if(is.matrix(x) || is.data.frame(x)) {
-# x <- data.matrix(x)
-# if(ncol(x) < 2) stop("at least 2 columns needed")
-# if(ncol(x) == 2) {
-# xlab <- "Index"
-# y <- x[,1]
-# z <- x[,2]
-# x <- seq_along(y)
-# }
-# else { ## >= 3 columns
-# colnames <- dimnames(x)[[2L]]
-# if(is.null(colnames)) {
-# zlab <- paste0(xlab,"[,3]")
-# ylab <- paste0(xlab,"[,2]")
-# xlab <- paste0(xlab,"[,1]")
-# }
-# else {
-# xlab <- colnames[1L]
-# ylab <- colnames[2L]
-# zlab <- colnames[3L]
-# }
-# y <- x[,2]
-# z <- x[,3]
-# x <- x[,1]
-# }
-# }
-# else if(is.list(x)) {
-# if (all(c("x", "y", "z") %in% names(x))) {
-# zlab <- paste0(xlab,"$z")
-# ylab <- paste0(xlab,"$y")
-# xlab <- paste0(xlab,"$x")
-# y <- x[["y"]]
-# z <- x[["z"]]
-# x <- x[["x"]]
-# } else
-# stop("'x' is a list, but does not have components 'x', 'y' and 'z'")
-# }
-# }
-#
-# ## Only x, y
-# if(!is.null(y) && is.null(z)) {
-# if(is.complex(x)) {
-# z <- y
-# y <- Im(x)
-# x <- Re(x)
-# zlab <- ylab
-# ylab <- paste0("Im(", xlab, ")")
-# xlab <- paste0("Re(", xlab, ")")
-# }
-# else if(is.complex(y)) {
-# z <- x
-# x <- Re(y)
-# y <- Im(y)
-# zlab <- xlab
-# xlab <- paste0("Re(", ylab, ")")
-# ylab <- paste0("Im(", ylab, ")")
-# }
-# else {
-# if(is.factor(x)) x <- as.numeric(x)
-# if(is.factor(y)) y <- as.numeric(y)
-# xlab <- "Index"
-# z <- y
-# y <- x
-# x <- seq_along(x)
-# }
-# }
-#
-# ## Lengths and recycle
-# if(((xl <- length(x)) != length(y)) || (xl != length(z))) {
-# if(recycle) {
-# ml <- max(xl, (yl <- length(y)), (zl <- length(z)))
-# if(xl < ml && !is.null(x)) x <- rep_len(x, ml)
-# if(yl < ml && !is.null(y)) y <- rep_len(y, ml)
-# if(zl < ml && !is.null(z)) z <- rep_len(z, ml)
-# }
-# else stop("'x', 'y' and 'z' lengths differ")
-# }
-#
-# ## log
-# if(length(log) && log != "") {
-# log <- strsplit(log, NULL)[[1L]]
-# if("x" %in% log && any(ii <- x <= 0 & !is.na(x))) {
-# n <- sum(ii)
-# warning(sprintf(ngettext(n,
-# "%d x value <= 0 omitted from logarithmic plot",
-# "%d x values <= 0 omitted from logarithmic plot"),
-# n), domain = NA)
-# x[ii] <- NA
-# }
-# if("y" %in% log && any(ii <- y <= 0 & !is.na(y))) {
-# n <- sum(ii)
-# warning(sprintf(ngettext(n,
-# "%d y value <= 0 omitted from logarithmic plot",
-# "%d y values <= 0 omitted from logarithmic plot"),
-# n), domain = NA)
-# y[ii] <- NA
-# }
-# if("z" %in% log && any(ii <- z <= 0 & !is.na(z))) {
-# n <- sum(ii)
-# warning(sprintf(ngettext(n,
-# "%d z value <= 0 omitted from logarithmic plot",
-# "%d z values <= 0 omitted from logarithmic plot"),
-# n), domain = NA)
-# z[ii] <- NA
-# }
-# }
-# list(x=as.double(x), y=as.double(y), z=as.double(z),
-# xlab=xlab, ylab=ylab, zlab=zlab)
-#}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Rnorm.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Random2.java
similarity index 81%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Rnorm.java
rename to com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Random2.java
index 03172618b8cdf1e94618d420e8a3a77e535d1307..df2b947922e550b7032b8c0d89e98674e732141f 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Rnorm.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Random2.java
@@ -11,34 +11,19 @@
*/
package com.oracle.truffle.r.nodes.builtin.stats;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
import static com.oracle.truffle.r.nodes.builtin.stats.StatsUtil.*;
import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
import com.oracle.truffle.r.runtime.rng.*;
/*
* Logic derived from GNU-R, see inline comments.
*/
-@RBuiltin(name = "rnorm", kind = SUBSTITUTE, parameterNames = {"n", "mean", "sd"})
-// TODO INTERNAL
-public abstract class Rnorm extends RBuiltinNode {
+public class Random2 {
- @Override
- public RNode[] getParameterValues() {
- return new RNode[]{null, ConstantNode.create(0d), ConstantNode.create(1d)};
- }
-
- @Specialization
@TruffleBoundary
- protected RDoubleVector rnorm(int n, double mean, double standardd) {
- controlVisibility();
+ public static RDoubleVector rnorm(int n, double mean, double standardd) {
double[] result = new double[n];
for (int i = 0; i < n; i++) {
result[i] = generateNorm(mean, standardd);
@@ -46,20 +31,6 @@ public abstract class Rnorm extends RBuiltinNode {
return RDataFactory.createDoubleVector(result, RDataFactory.COMPLETE_VECTOR);
}
- @Specialization
- @TruffleBoundary
- protected RDoubleVector rnorm(int n, int mean, int standardd) {
- controlVisibility();
- return rnorm(n, (double) mean, (double) standardd);
- }
-
- @Specialization
- @TruffleBoundary
- protected RDoubleVector rnorm(double n, double mean, double standardd) {
- controlVisibility();
- return rnorm((int) n, mean, standardd);
- }
-
// from GNUR: rnorm.c
private static double generateNorm(double mean, double standardd) {
return mean + standardd * normRand();
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Runif.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Runif.java
index d532fd386ab692ae07cc1b9ec2a3424076480486..9fdafd04fa4446f06f1f114fd1e5919015620d3b 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Runif.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Runif.java
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2013, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2013, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -22,44 +22,15 @@
*/
package com.oracle.truffle.r.nodes.builtin.stats;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import java.util.function.*;
-
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.api.utilities.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.access.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.runtime.*;
-import com.oracle.truffle.r.runtime.RError.Message;
import com.oracle.truffle.r.runtime.data.*;
-import com.oracle.truffle.r.runtime.data.model.*;
-import com.oracle.truffle.r.runtime.ops.na.*;
import com.oracle.truffle.r.runtime.rng.*;
/**
- * TODO GnuR checks/updates {@code .Random.seed} across this call.
+ * TODO GnuR checks/updates {@code .Random.seed} across this call. TODO Honor min/max.
*/
-@RBuiltin(name = "runif", kind = SUBSTITUTE, parameterNames = {"n", "min", "max"})
-public abstract class Runif extends RBuiltinNode {
-
- private final ValueProfile lengthProfile = ValueProfile.createPrimitiveProfile();
- private final NAProfile naProfile = NAProfile.create();
-
- @Override
- public RNode[] getParameterValues() {
- // n, min = 0, max = 1
- return new RNode[]{ConstantNode.create(RMissing.instance), ConstantNode.create(0), ConstantNode.create(1)};
- }
-
- private RDoubleVector runif(int vectorLength, IntSupplier firstElement) {
- controlVisibility();
- int length = lengthProfile.profile(vectorLength) == 1 ? firstElement.getAsInt() : vectorLength;
+public class Runif {
- if (naProfile.isNA(length)) {
- throw RError.error(getEncapsulatingSourceSection(), Message.INVALID_UNNAMED_ARGUMENTS);
- }
+ public static RDoubleVector runif(int length, @SuppressWarnings("unused") double min, @SuppressWarnings("unused") double max) {
double[] result = new double[length];
for (int i = 0; i < length; i++) {
result[i] = RRNG.unifRand();
@@ -67,48 +38,4 @@ public abstract class Runif extends RBuiltinNode {
return RDataFactory.createDoubleVector(result, RDataFactory.COMPLETE_VECTOR);
}
- @Specialization
- protected RDoubleVector runif(int n) {
- return runif(1, () -> n);
- }
-
- @Specialization
- protected RDoubleVector runif(double d) {
- return runif(1, () -> RRuntime.double2int(d));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractIntVector v) {
- return runif(v.getLength(), () -> v.getDataAt(0));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractDoubleVector v) {
- return runif(v.getLength(), () -> RRuntime.double2int(v.getDataAt(0)));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractLogicalVector v) {
- return runif(v.getLength(), () -> RRuntime.logical2int(v.getDataAt(0)));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractRawVector v) {
- return runif(v.getLength(), () -> RRuntime.raw2int(v.getDataAt(0)));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractStringVector v) {
- return runif(v.getLength(), () -> RRuntime.string2int(v.getDataAt(0)));
- }
-
- @Specialization
- protected RDoubleVector runif(RAbstractComplexVector v) {
- return runif(v.getLength(), () -> RRuntime.complex2int(v.getDataAt(0)));
- }
-
- @Fallback
- protected RDoubleVector fallback(@SuppressWarnings("unused") Object v) {
- throw RError.error(getEncapsulatingSourceSection(), Message.INVALID_UNNAMED_ARGUMENTS);
- }
}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/SplineFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/SplineFunctions.java
index 022f3995be1370bf8315b5ab786c6a0b314a7bf8..109a8be2f276e88adaf93b668c43ba9b09abb902 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/SplineFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/SplineFunctions.java
@@ -5,18 +5,13 @@
*
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
* Copyright (C) 1998--2012 The R Core Team
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates
*
* All rights reserved.
*/
package com.oracle.truffle.r.nodes.builtin.stats;
-import static com.oracle.truffle.r.runtime.RBuiltinKind.*;
-
-import com.oracle.truffle.api.dsl.*;
-import com.oracle.truffle.r.nodes.*;
-import com.oracle.truffle.r.nodes.builtin.*;
-import com.oracle.truffle.r.nodes.unary.*;
+import com.oracle.truffle.api.CompilerDirectives.*;
import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
import com.oracle.truffle.r.runtime.ops.*;
@@ -29,414 +24,389 @@ import com.oracle.truffle.r.runtime.ops.*;
*/
public class SplineFunctions {
- @RBuiltin(name = "SplineCoef", kind = SUBSTITUTE, parameterNames = {"method", "x", "y"})
- public abstract static class SplineCoef extends RBuiltinNode {
-
- @CreateCast("arguments")
- protected RNode[] castVectorArguments(RNode[] arguments) {
- // x,y arguments are at indices 1,2
- arguments[1] = CastDoubleNodeGen.create(arguments[1], true, true, true);
- arguments[2] = CastDoubleNodeGen.create(arguments[2], true, true, true);
- return arguments;
+ @TruffleBoundary
+ public static RList splineCoef(int method, RDoubleVector x, RDoubleVector y) {
+ final int n = x.getLength();
+ if (y.getLength() != n) {
+ throw RError.error(RError.Message.INPUTS_DIFFERENT_LENGTHS);
}
- @Specialization
- protected RList splineCoef(int method, RDoubleVector x, RDoubleVector y) {
- final int n = x.getLength();
- if (y.getLength() != n) {
- throw RError.error(RError.Message.INPUTS_DIFFERENT_LENGTHS);
- }
+ double[] b = new double[n];
+ double[] c = new double[n];
+ double[] d = new double[n];
- double[] b = new double[n];
- double[] c = new double[n];
- double[] d = new double[n];
+ splineCoef(method, n, x.getDataWithoutCopying(), y.getDataWithoutCopying(), b, c, d);
- splineCoef(method, n, x.getDataWithoutCopying(), y.getDataWithoutCopying(), b, c, d);
+ final boolean complete = x.isComplete() && y.isComplete();
+ RDoubleVector bv = RDataFactory.createDoubleVector(b, complete);
+ RDoubleVector cv = RDataFactory.createDoubleVector(c, complete);
+ RDoubleVector dv = RDataFactory.createDoubleVector(d, complete);
+ Object[] resultData = new Object[]{method, n, x, y, bv, cv, dv};
+ RStringVector resultNames = RDataFactory.createStringVector(new String[]{"method", "n", "x", "y", "b", "c", "d"}, RDataFactory.COMPLETE_VECTOR);
+ return RDataFactory.createList(resultData, resultNames);
+ }
- final boolean complete = x.isComplete() && y.isComplete();
- RDoubleVector bv = RDataFactory.createDoubleVector(b, complete);
- RDoubleVector cv = RDataFactory.createDoubleVector(c, complete);
- RDoubleVector dv = RDataFactory.createDoubleVector(d, complete);
- Object[] resultData = new Object[]{method, n, x, y, bv, cv, dv};
- RStringVector resultNames = RDataFactory.createStringVector(new String[]{"method", "n", "x", "y", "b", "c", "d"}, RDataFactory.COMPLETE_VECTOR);
- return RDataFactory.createList(resultData, resultNames);
+ private static void splineCoef(int method, int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
+ switch (method) {
+ case 1:
+ periodicSpline(n, x, y, b, c, d);
+ break;
+ case 2:
+ naturalSpline(n, x, y, b, c, d);
+ break;
+ case 3:
+ fmmSpline(n, x, y, b, c, d);
+ break;
}
+ }
- private static void splineCoef(int method, int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
- switch (method) {
- case 1:
- periodicSpline(n, x, y, b, c, d);
- break;
- case 2:
- naturalSpline(n, x, y, b, c, d);
- break;
- case 3:
- fmmSpline(n, x, y, b, c, d);
- break;
- }
+ /*
+ * Periodic Spline --------------- The end conditions here match spline (and its derivatives) at
+ * x[1] and x[n].
+ *
+ * Note: There is an explicit check that the user has supplied data with y[1] equal to y[n].
+ */
+ private static void periodicSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
+ double s;
+ int i;
+ int nm2;
+
+ double[] e = new double[n];
+
+ if (n < 2 || y[0] != y[n - 1]) {
+ throw RInternalError.shouldNotReachHere("periodic spline: domain error");
}
- /*
- * Periodic Spline --------------- The end conditions here match spline (and its
- * derivatives) at x[1] and x[n].
- *
- * Note: There is an explicit check that the user has supplied data with y[1] equal to y[n].
- */
- private static void periodicSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
- double s;
- int i;
- int nm2;
+ if (n == 2) {
+ b[0] = 0.0;
+ b[1] = 0.0;
+ c[0] = 0.0;
+ c[1] = 0.0;
+ d[0] = 0.0;
+ d[1] = 0.0;
+ return;
+ } else if (n == 3) {
+ double r = -(y[0] - y[1]) * (x[0] - 2 * x[1] + x[2]) / (x[2] - x[1]) / (x[1] - x[0]);
+ b[0] = r;
+ b[1] = r;
+ b[2] = r;
+ c[0] = -3 * (y[0] - y[1]) / (x[2] - x[1]) / (x[1] - x[0]);
+ c[1] = -c[0];
+ c[2] = c[0];
+ d[0] = -2 * c[0] / 3 / (x[1] - x[0]);
+ d[1] = -d[0] * (x[1] - x[0]) / (x[2] - x[1]);
+ d[2] = d[0];
+ return;
+ }
- double[] e = new double[n];
+ /* else --------- n >= 4 --------- */
+ nm2 = n - 2;
- if (n < 2 || y[0] != y[n - 1]) {
- throw RInternalError.shouldNotReachHere("periodic spline: domain error");
- }
+ /* Set up the matrix system */
+ /* A = diagonal B = off-diagonal C = rhs */
- if (n == 2) {
- b[0] = 0.0;
- b[1] = 0.0;
- c[0] = 0.0;
- c[1] = 0.0;
- d[0] = 0.0;
- d[1] = 0.0;
- return;
- } else if (n == 3) {
- double r = -(y[0] - y[1]) * (x[0] - 2 * x[1] + x[2]) / (x[2] - x[1]) / (x[1] - x[0]);
- b[0] = r;
- b[1] = r;
- b[2] = r;
- c[0] = -3 * (y[0] - y[1]) / (x[2] - x[1]) / (x[1] - x[0]);
- c[1] = -c[0];
- c[2] = c[0];
- d[0] = -2 * c[0] / 3 / (x[1] - x[0]);
- d[1] = -d[0] * (x[1] - x[0]) / (x[2] - x[1]);
- d[2] = d[0];
- return;
- }
+ double[] mA = b;
+ double[] mB = d;
+ double[] mC = c;
- /* else --------- n >= 4 --------- */
- nm2 = n - 2;
+ mB[0] = x[1] - x[0];
+ mB[nm2] = x[n - 1] - x[nm2];
+ mA[0] = 2.0 * (mB[0] + mB[nm2]);
+ mC[0] = (y[1] - y[0]) / mB[0] - (y[n - 1] - y[nm2]) / mB[nm2];
- /* Set up the matrix system */
- /* A = diagonal B = off-diagonal C = rhs */
+ for (i = 1; i < n - 1; i++) {
+ mB[i] = x[i + 1] - x[i];
+ mA[i] = 2.0 * (mB[i] + mB[i - 1]);
+ mC[i] = (y[i + 1] - y[i]) / mB[i] - (y[i] - y[i - 1]) / mB[i - 1];
+ }
- double[] mA = b;
- double[] mB = d;
- double[] mC = c;
+ /* Choleski decomposition */
- mB[0] = x[1] - x[0];
- mB[nm2] = x[n - 1] - x[nm2];
- mA[0] = 2.0 * (mB[0] + mB[nm2]);
- mC[0] = (y[1] - y[0]) / mB[0] - (y[n - 1] - y[nm2]) / mB[nm2];
+ double[] mL = b;
+ double[] mM = d;
+ double[] mE = e;
- for (i = 1; i < n - 1; i++) {
- mB[i] = x[i + 1] - x[i];
- mA[i] = 2.0 * (mB[i] + mB[i - 1]);
- mC[i] = (y[i + 1] - y[i]) / mB[i] - (y[i] - y[i - 1]) / mB[i - 1];
+ mL[0] = Math.sqrt(mA[0]);
+ mE[0] = (x[n - 1] - x[nm2]) / mL[0];
+ s = 0.0;
+ for (i = 0; i <= nm2 - 2; i++) {
+ mM[i] = mB[i] / mL[i];
+ if (i != 0) {
+ mE[i] = -mE[i - 1] * mM[i - 1] / mL[i];
}
+ mL[i + 1] = Math.sqrt(mA[i + 1] - mM[i] * mM[i]);
+ s = s + mE[i] * mE[i];
+ }
+ mM[nm2 - 1] = (mB[nm2 - 1] - mE[nm2 - 2] * mM[nm2 - 2]) / mL[nm2 - 1];
+ mL[nm2] = Math.sqrt(mA[nm2] - mM[nm2 - 1] * mM[nm2 - 1] - s);
- /* Choleski decomposition */
+ /* Forward Elimination */
- double[] mL = b;
- double[] mM = d;
- double[] mE = e;
+ double[] mY = c;
+ double[] mD = c;
- mL[0] = Math.sqrt(mA[0]);
- mE[0] = (x[n - 1] - x[nm2]) / mL[0];
- s = 0.0;
- for (i = 0; i <= nm2 - 2; i++) {
- mM[i] = mB[i] / mL[i];
- if (i != 0) {
- mE[i] = -mE[i - 1] * mM[i - 1] / mL[i];
- }
- mL[i + 1] = Math.sqrt(mA[i + 1] - mM[i] * mM[i]);
- s = s + mE[i] * mE[i];
- }
- mM[nm2 - 1] = (mB[nm2 - 1] - mE[nm2 - 2] * mM[nm2 - 2]) / mL[nm2 - 1];
- mL[nm2] = Math.sqrt(mA[nm2] - mM[nm2 - 1] * mM[nm2 - 1] - s);
-
- /* Forward Elimination */
+ mY[0] = mD[0] / mL[0];
+ s = 0.0;
+ for (i = 1; i <= nm2 - 1; i++) {
+ mY[i] = (mD[i] - mM[i - 1] * mY[i - 1]) / mL[i];
+ s = s + mE[i - 1] * mY[i - 1];
+ }
+ mY[nm2] = (mD[nm2] - mM[nm2 - 1] * mY[nm2 - 1] - s) / mL[nm2];
- double[] mY = c;
- double[] mD = c;
+ double[] mX = c;
- mY[0] = mD[0] / mL[0];
- s = 0.0;
- for (i = 1; i <= nm2 - 1; i++) {
- mY[i] = (mD[i] - mM[i - 1] * mY[i - 1]) / mL[i];
- s = s + mE[i - 1] * mY[i - 1];
- }
- mY[nm2] = (mD[nm2] - mM[nm2 - 1] * mY[nm2 - 1] - s) / mL[nm2];
+ mX[nm2] = mY[nm2] / mL[nm2];
+ mX[nm2 - 1] = (mY[nm2 - 1] - mM[nm2 - 1] * mX[nm2]) / mL[nm2 - 1];
+ for (i = nm2 - 2; i >= 0; i--) {
+ mX[i] = (mY[i] - mM[i] * mX[i + 1] - mE[i] * mX[nm2]) / mL[i];
+ }
- double[] mX = c;
+ /* Wrap around */
- mX[nm2] = mY[nm2] / mL[nm2];
- mX[nm2 - 1] = (mY[nm2 - 1] - mM[nm2 - 1] * mX[nm2]) / mL[nm2 - 1];
- for (i = nm2 - 2; i >= 0; i--) {
- mX[i] = (mY[i] - mM[i] * mX[i + 1] - mE[i] * mX[nm2]) / mL[i];
- }
+ mX[n - 1] = mX[0];
- /* Wrap around */
+ /* Compute polynomial coefficients */
- mX[n - 1] = mX[0];
+ for (i = 0; i <= nm2; i++) {
+ s = x[i + 1] - x[i];
+ b[i] = (y[i + 1] - y[i]) / s - s * (c[i + 1] + 2.0 * c[i]);
+ d[i] = (c[i + 1] - c[i]) / s;
+ c[i] = 3.0 * c[i];
+ }
+ b[n - 1] = b[0];
+ c[n - 1] = c[0];
+ d[n - 1] = d[0];
+ return;
+ }
- /* Compute polynomial coefficients */
+ /*
+ * Natural Splines --------------- Here the end-conditions are determined by setting the second
+ * derivative of the spline at the end-points to equal to zero.
+ *
+ * There are n-2 unknowns (y[i]'' at x[2], ..., x[n-1]) and n-2 equations to determine them.
+ * Either Choleski or Gaussian elimination could be used.
+ */
+ private static void naturalSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
+ int nm2;
+ int i;
+ double t;
+
+ if (n < 2) {
+ throw RInternalError.shouldNotReachHere("periodic spline: domain error");
+ }
- for (i = 0; i <= nm2; i++) {
- s = x[i + 1] - x[i];
- b[i] = (y[i + 1] - y[i]) / s - s * (c[i + 1] + 2.0 * c[i]);
- d[i] = (c[i + 1] - c[i]) / s;
- c[i] = 3.0 * c[i];
- }
- b[n - 1] = b[0];
- c[n - 1] = c[0];
- d[n - 1] = d[0];
+ if (n < 3) {
+ t = (y[1] - y[0]);
+ b[0] = t / (x[1] - x[0]);
+ b[1] = b[0];
+ c[0] = 0.0;
+ c[1] = 0.0;
+ d[0] = 0.0;
+ d[1] = 0.0;
return;
}
- /*
- * Natural Splines --------------- Here the end-conditions are determined by setting the
- * second derivative of the spline at the end-points to equal to zero.
- *
- * There are n-2 unknowns (y[i]'' at x[2], ..., x[n-1]) and n-2 equations to determine them.
- * Either Choleski or Gaussian elimination could be used.
- */
- private static void naturalSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
- int nm2;
- int i;
- double t;
+ nm2 = n - 2;
- if (n < 2) {
- throw RInternalError.shouldNotReachHere("periodic spline: domain error");
- }
+ /* Set up the tridiagonal system */
+ /* b = diagonal, d = offdiagonal, c = right hand side */
- if (n < 3) {
- t = (y[1] - y[0]);
- b[0] = t / (x[1] - x[0]);
- b[1] = b[0];
- c[0] = 0.0;
- c[1] = 0.0;
- d[0] = 0.0;
- d[1] = 0.0;
- return;
- }
+ d[0] = x[1] - x[0];
+ c[1] = (y[1] - y[0]) / d[0];
+ for (i = 1; i < n - 1; i++) {
+ d[i] = x[i + 1] - x[i];
+ b[i] = 2.0 * (d[i - 1] + d[i]);
+ c[i + 1] = (y[i + 1] - y[i]) / d[i];
+ c[i] = c[i + 1] - c[i];
+ }
- nm2 = n - 2;
+ /* Gaussian elimination */
- /* Set up the tridiagonal system */
- /* b = diagonal, d = offdiagonal, c = right hand side */
+ for (i = 2; i < n - 1; i++) {
+ t = d[i - 1] / b[i - 1];
+ b[i] = b[i] - t * d[i - 1];
+ c[i] = c[i] - t * c[i - 1];
+ }
- d[0] = x[1] - x[0];
- c[1] = (y[1] - y[0]) / d[0];
- for (i = 1; i < n - 1; i++) {
- d[i] = x[i + 1] - x[i];
- b[i] = 2.0 * (d[i - 1] + d[i]);
- c[i + 1] = (y[i + 1] - y[i]) / d[i];
- c[i] = c[i + 1] - c[i];
- }
+ /* Backward substitution */
- /* Gaussian elimination */
+ c[nm2] = c[nm2] / b[nm2];
+ for (i = n - 3; i > 0; i--) {
+ c[i] = (c[i] - d[i] * c[i + 1]) / b[i];
+ }
- for (i = 2; i < n - 1; i++) {
- t = d[i - 1] / b[i - 1];
- b[i] = b[i] - t * d[i - 1];
- c[i] = c[i] - t * c[i - 1];
- }
+ /* End conditions */
- /* Backward substitution */
+ c[0] = c[n - 1] = 0.0;
- c[nm2] = c[nm2] / b[nm2];
- for (i = n - 3; i > 0; i--) {
- c[i] = (c[i] - d[i] * c[i + 1]) / b[i];
- }
+ /* Get cubic coefficients */
- /* End conditions */
+ b[0] = (y[1] - y[0]) / d[0] - d[i] * c[1];
+ c[0] = 0.0;
+ d[0] = c[1] / d[0];
+ b[n - 1] = (y[n - 1] - y[nm2]) / d[nm2] + d[nm2] * c[nm2];
+ for (i = 1; i < n - 1; i++) {
+ b[i] = (y[i + 1] - y[i]) / d[i] - d[i] * (c[i + 1] + 2.0 * c[i]);
+ d[i] = (c[i + 1] - c[i]) / d[i];
+ c[i] = 3.0 * c[i];
+ }
+ c[n - 1] = 0.0;
+ d[n - 1] = 0.0;
- c[0] = c[n - 1] = 0.0;
+ return;
+ }
- /* Get cubic coefficients */
+ /*
+ * Splines a la Forsythe Malcolm and Moler --------------------------------------- In this case
+ * the end-conditions are determined by fitting cubic polynomials to the first and last 4 points
+ * and matching the third derivitives of the spline at the end-points to the third derivatives
+ * of these cubics at the end-points.
+ */
+ private static void fmmSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
+ int nm2;
+ int i;
+ double t;
+
+ if (n < 2) {
+ throw RInternalError.shouldNotReachHere("periodic spline: domain error");
+ }
- b[0] = (y[1] - y[0]) / d[0] - d[i] * c[1];
+ if (n < 3) {
+ t = (y[1] - y[0]);
+ b[0] = t / (x[1] - x[0]);
+ b[1] = b[0];
c[0] = 0.0;
- d[0] = c[1] / d[0];
- b[n - 1] = (y[n - 1] - y[nm2]) / d[nm2] + d[nm2] * c[nm2];
- for (i = 1; i < n - 1; i++) {
- b[i] = (y[i + 1] - y[i]) / d[i] - d[i] * (c[i + 1] + 2.0 * c[i]);
- d[i] = (c[i + 1] - c[i]) / d[i];
- c[i] = 3.0 * c[i];
- }
- c[n - 1] = 0.0;
- d[n - 1] = 0.0;
-
+ c[1] = 0.0;
+ d[0] = 0.0;
+ d[1] = 0.0;
return;
}
- /*
- * Splines a la Forsythe Malcolm and Moler --------------------------------------- In this
- * case the end-conditions are determined by fitting cubic polynomials to the first and last
- * 4 points and matching the third derivitives of the spline at the end-points to the third
- * derivatives of these cubics at the end-points.
- */
- private static void fmmSpline(int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
- int nm2;
- int i;
- double t;
-
- if (n < 2) {
- throw RInternalError.shouldNotReachHere("periodic spline: domain error");
- }
-
- if (n < 3) {
- t = (y[1] - y[0]);
- b[0] = t / (x[1] - x[0]);
- b[1] = b[0];
- c[0] = 0.0;
- c[1] = 0.0;
- d[0] = 0.0;
- d[1] = 0.0;
- return;
- }
+ nm2 = n - 2;
- nm2 = n - 2;
+ /* Set up tridiagonal system */
+ /* b = diagonal, d = offdiagonal, c = right hand side */
- /* Set up tridiagonal system */
- /* b = diagonal, d = offdiagonal, c = right hand side */
-
- d[0] = x[1] - x[0];
- c[1] = (y[1] - y[0]) / d[0]; /* = +/- Inf for x[1]=x[2] -- problem? */
- for (i = 1; i < n - 1; i++) {
- d[i] = x[i + 1] - x[i];
- b[i] = 2.0 * (d[i - 1] + d[i]);
- c[i + 1] = (y[i + 1] - y[i]) / d[i];
- c[i] = c[i + 1] - c[i];
- }
-
- /* End conditions. */
- /* Third derivatives at x[0] and x[n-1] obtained */
- /* from divided differences */
+ d[0] = x[1] - x[0];
+ c[1] = (y[1] - y[0]) / d[0]; /* = +/- Inf for x[1]=x[2] -- problem? */
+ for (i = 1; i < n - 1; i++) {
+ d[i] = x[i + 1] - x[i];
+ b[i] = 2.0 * (d[i - 1] + d[i]);
+ c[i + 1] = (y[i + 1] - y[i]) / d[i];
+ c[i] = c[i + 1] - c[i];
+ }
- b[0] = -d[0];
- b[n - 1] = -d[nm2];
- c[0] = 0.0;
- c[n - 1] = 0.0;
- if (n > 3) {
- c[0] = c[2] / (x[3] - x[1]) - c[1] / (x[2] - x[0]);
- c[n - 1] = c[nm2] / (x[n - 1] - x[n - 3]) - c[n - 3] / (x[nm2] - x[n - 4]);
- c[0] = c[0] * d[0] * d[0] / (x[3] - x[0]);
- c[n - 1] = -c[n - 1] * d[nm2] * d[nm2] / (x[n - 1] - x[n - 4]);
- }
+ /* End conditions. */
+ /* Third derivatives at x[0] and x[n-1] obtained */
+ /* from divided differences */
+
+ b[0] = -d[0];
+ b[n - 1] = -d[nm2];
+ c[0] = 0.0;
+ c[n - 1] = 0.0;
+ if (n > 3) {
+ c[0] = c[2] / (x[3] - x[1]) - c[1] / (x[2] - x[0]);
+ c[n - 1] = c[nm2] / (x[n - 1] - x[n - 3]) - c[n - 3] / (x[nm2] - x[n - 4]);
+ c[0] = c[0] * d[0] * d[0] / (x[3] - x[0]);
+ c[n - 1] = -c[n - 1] * d[nm2] * d[nm2] / (x[n - 1] - x[n - 4]);
+ }
- /* Gaussian elimination */
+ /* Gaussian elimination */
- for (i = 1; i <= n - 1; i++) {
- t = d[i - 1] / b[i - 1];
- b[i] = b[i] - t * d[i - 1];
- c[i] = c[i] - t * c[i - 1];
- }
+ for (i = 1; i <= n - 1; i++) {
+ t = d[i - 1] / b[i - 1];
+ b[i] = b[i] - t * d[i - 1];
+ c[i] = c[i] - t * c[i - 1];
+ }
- /* Backward substitution */
+ /* Backward substitution */
- c[n - 1] = c[n - 1] / b[n - 1];
- for (i = nm2; i >= 0; i--) {
- c[i] = (c[i] - d[i] * c[i + 1]) / b[i];
- }
+ c[n - 1] = c[n - 1] / b[n - 1];
+ for (i = nm2; i >= 0; i--) {
+ c[i] = (c[i] - d[i] * c[i + 1]) / b[i];
+ }
- /* c[i] is now the sigma[i-1] of the text */
- /* Compute polynomial coefficients */
+ /* c[i] is now the sigma[i-1] of the text */
+ /* Compute polynomial coefficients */
- b[n - 1] = (y[n - 1] - y[n - 2]) / d[n - 2] + d[n - 2] * (c[n - 2] + 2.0 * c[n - 1]);
- for (i = 0; i <= nm2; i++) {
- b[i] = (y[i + 1] - y[i]) / d[i] - d[i] * (c[i + 1] + 2.0 * c[i]);
- d[i] = (c[i + 1] - c[i]) / d[i];
- c[i] = 3.0 * c[i];
- }
- c[n - 1] = 3.0 * c[n - 1];
- d[n - 1] = d[nm2];
- return;
+ b[n - 1] = (y[n - 1] - y[n - 2]) / d[n - 2] + d[n - 2] * (c[n - 2] + 2.0 * c[n - 1]);
+ for (i = 0; i <= nm2; i++) {
+ b[i] = (y[i + 1] - y[i]) / d[i] - d[i] * (c[i + 1] + 2.0 * c[i]);
+ d[i] = (c[i + 1] - c[i]) / d[i];
+ c[i] = 3.0 * c[i];
}
-
+ c[n - 1] = 3.0 * c[n - 1];
+ d[n - 1] = d[nm2];
+ return;
}
- @RBuiltin(name = "SplineEval", kind = SUBSTITUTE, parameterNames = {"xout", "z"})
- public abstract static class SplineEval extends RBuiltinNode {
-
- @CreateCast("arguments")
- protected RNode[] castVectorArguments(RNode[] arguments) {
- // xout argument is at index 0
- arguments[0] = CastDoubleNodeGen.create(arguments[0], true, true, true);
- return arguments;
- }
+ @TruffleBoundary
+ public static RDoubleVector splineEval(RDoubleVector xout, RList z) {
+ int nu = xout.getLength();
+ double[] yout = new double[nu];
+ int method = (int) z.getDataAt(z.getElementIndexByName("method"));
+ int nx = (int) z.getDataAt(z.getElementIndexByName("n"));
+ RDoubleVector x = (RDoubleVector) z.getDataAt(z.getElementIndexByName("x"));
+ RDoubleVector y = (RDoubleVector) z.getDataAt(z.getElementIndexByName("y"));
+ RDoubleVector b = (RDoubleVector) z.getDataAt(z.getElementIndexByName("b"));
+ RDoubleVector c = (RDoubleVector) z.getDataAt(z.getElementIndexByName("c"));
+ RDoubleVector d = (RDoubleVector) z.getDataAt(z.getElementIndexByName("d"));
+
+ splineEval(method, nu, xout.getDataWithoutCopying(), yout, nx, x.getDataWithoutCopying(), y.getDataWithoutCopying(), b.getDataWithoutCopying(), c.getDataWithoutCopying(),
+ d.getDataWithoutCopying());
+ return RDataFactory.createDoubleVector(yout, xout.isComplete() && x.isComplete() && y.isComplete());
+ }
- @Specialization
- protected RDoubleVector splineEval(RDoubleVector xout, RList z) {
- int nu = xout.getLength();
- double[] yout = new double[nu];
- int method = (int) z.getDataAt(z.getElementIndexByName("method"));
- int nx = (int) z.getDataAt(z.getElementIndexByName("n"));
- RDoubleVector x = (RDoubleVector) z.getDataAt(z.getElementIndexByName("x"));
- RDoubleVector y = (RDoubleVector) z.getDataAt(z.getElementIndexByName("y"));
- RDoubleVector b = (RDoubleVector) z.getDataAt(z.getElementIndexByName("b"));
- RDoubleVector c = (RDoubleVector) z.getDataAt(z.getElementIndexByName("c"));
- RDoubleVector d = (RDoubleVector) z.getDataAt(z.getElementIndexByName("d"));
-
- splineEval(method, nu, xout.getDataWithoutCopying(), yout, nx, x.getDataWithoutCopying(), y.getDataWithoutCopying(), b.getDataWithoutCopying(), c.getDataWithoutCopying(),
- d.getDataWithoutCopying());
- return RDataFactory.createDoubleVector(yout, xout.isComplete() && x.isComplete() && y.isComplete());
+ private static void splineEval(int method, int nu, double[] u, double[] v, int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
+ /*
+ * Evaluate v[l] := spline(u[l], ...), l = 1,..,nu, i.e. 0:(nu-1) Nodes x[i], coef (y[i];
+ * b[i],c[i],d[i]); i = 1,..,n , i.e. 0:(*n-1)
+ */
+ final int nm1 = n - 1;
+ int i;
+ int j;
+ int k;
+ int l;
+ double ul;
+ double dx;
+ double tmp;
+
+ if (method == 1 && n > 1) { /* periodic */
+ dx = x[nm1] - x[0];
+ for (l = 0; l < nu; l++) {
+ v[l] = BinaryArithmetic.fmod(u[l] - x[0], dx);
+ if (v[l] < 0.0) {
+ v[l] += dx;
+ }
+ v[l] += x[0];
+ }
+ } else {
+ for (l = 0; l < nu; l++) {
+ v[l] = u[l];
+ }
}
- private static void splineEval(int method, int nu, double[] u, double[] v, int n, double[] x, double[] y, double[] b, double[] c, double[] d) {
- /*
- * Evaluate v[l] := spline(u[l], ...), l = 1,..,nu, i.e. 0:(nu-1) Nodes x[i], coef
- * (y[i]; b[i],c[i],d[i]); i = 1,..,n , i.e. 0:(*n-1)
- */
- final int nm1 = n - 1;
- int i;
- int j;
- int k;
- int l;
- double ul;
- double dx;
- double tmp;
-
- if (method == 1 && n > 1) { /* periodic */
- dx = x[nm1] - x[0];
- for (l = 0; l < nu; l++) {
- v[l] = BinaryArithmetic.fmod(u[l] - x[0], dx);
- if (v[l] < 0.0) {
- v[l] += dx;
+ for (l = 0, i = 0; l < nu; l++) {
+ ul = v[l];
+ if (ul < x[i] || (i < nm1 && x[i + 1] < ul)) {
+ /* reset i such that x[i] <= ul <= x[i+1] : */
+ i = 0;
+ j = n;
+ do {
+ k = (i + j) / 2;
+ if (ul < x[k]) {
+ j = k;
+ } else {
+ i = k;
}
- v[l] += x[0];
- }
- } else {
- for (l = 0; l < nu; l++) {
- v[l] = u[l];
- }
+ } while (j > i + 1);
}
+ dx = ul - x[i];
+ /* for natural splines extrapolate linearly left */
+ tmp = (method == 2 && ul < x[0]) ? 0.0 : d[i];
- for (l = 0, i = 0; l < nu; l++) {
- ul = v[l];
- if (ul < x[i] || (i < nm1 && x[i + 1] < ul)) {
- /* reset i such that x[i] <= ul <= x[i+1] : */
- i = 0;
- j = n;
- do {
- k = (i + j) / 2;
- if (ul < x[k]) {
- j = k;
- } else {
- i = k;
- }
- } while (j > i + 1);
- }
- dx = ul - x[i];
- /* for natural splines extrapolate linearly left */
- tmp = (method == 2 && ul < x[0]) ? 0.0 : d[i];
-
- v[l] = y[i] + dx * (b[i] + dx * (c[i] + dx * tmp));
- }
+ v[l] = y[i] + dx * (b[i] + dx * (c[i] + dx * tmp));
}
-
}
}
diff --git a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/UseMethodDispatchNode.java b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/UseMethodDispatchNode.java
index 72b10dd14d665c517c900331f626d03e2dec064e..702ecbde5506df12efe874964baa421a8e7b7904 100644
--- a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/UseMethodDispatchNode.java
+++ b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/UseMethodDispatchNode.java
@@ -22,6 +22,17 @@ import com.oracle.truffle.r.runtime.*;
import com.oracle.truffle.r.runtime.data.*;
import com.oracle.truffle.r.runtime.env.frame.*;
+/**
+ * {@code UseMethod} is typically called like this:
+ *
+ * <pre>
+ * f <- function(x, ...) UseMethod("f")
+ * </pre>
+ *
+ * Locating the correct call depends on the class of {@code x}, and the search starts in the
+ * enclosing (parent) environment of {@code f}, which, for packages, which is where most of these
+ * definitions occur, will be the package {@code namepace} enviromnent.
+ */
public class UseMethodDispatchNode extends S3DispatchNode {
private final BranchProfile errorProfile = BranchProfile.create();
@@ -40,7 +51,7 @@ public class UseMethodDispatchNode extends S3DispatchNode {
funFrame = frame;
}
if (targetFunction == null) {
- findTargetFunction(funFrame);
+ findTargetFunction(RArguments.getEnclosingFrame(frame));
}
return executeHelper(frame, funFrame);
}
@@ -53,13 +64,14 @@ public class UseMethodDispatchNode extends S3DispatchNode {
if (funFrame == null) {
funFrame = frame;
}
- findTargetFunction(funFrame);
+ findTargetFunction(RArguments.getEnclosingFrame(frame));
return executeHelper(frame, funFrame);
}
@Override
public Object executeInternal(VirtualFrame frame, Object[] args) {
if (targetFunction == null) {
+ // TBD getEnclosing?
findTargetFunction(frame);
}
return executeHelper(frame, args);
@@ -68,6 +80,7 @@ public class UseMethodDispatchNode extends S3DispatchNode {
@Override
public Object executeInternal(VirtualFrame frame, RStringVector aType, Object[] args) {
this.type = aType;
+ // TBD getEnclosing?
findTargetFunction(frame);
return executeHelper(frame, args);
}
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/R/Rprofile.R b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/R/Rprofile.R
index 83c75f4a0192cdb6ea2b1b99cdf105a7a9adfea1..615eada4ef16efc91b5bd0edccc8b2e7da7c172d 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/R/Rprofile.R
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/R/Rprofile.R
@@ -53,7 +53,7 @@ if(!interactive() && is.null(getOption("showErrorCalls")))
local({dp <- Sys.getenv("R_DEFAULT_PACKAGES")
if(identical(dp, "")) # marginally faster to do methods last
- dp <- c("datasets", "utils", "grDevices", "graphics",
+ dp <- c("fastr", "datasets", "utils", "grDevices", "graphics",
"stats", "methods")
else if(identical(dp, "NULL")) dp <- character(0)
else dp <- strsplit(dp, ",")[[1]]
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RError.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RError.java
index 323ddad2261368fb6fb1622b02771ef4c877e9c4..c8071a3966e7ab8afff73e1eaaf04fdee47b655d 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RError.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RError.java
@@ -435,6 +435,7 @@ public final class RError extends RuntimeException {
DIMNAMES_DONT_MATCH_EXTENT("length of 'dimnames' [%d] not equal to array extent"),
MUST_BE_ATOMIC("'%s' must be atomic"),
MUST_BE_NULL_OR_STRING("'%s' must be NULL or a character vector"),
+ IS_NULL("'%s' is NULL"),
MUST_BE_SCALAR("'%s' must be of length 1"),
ROWS_MUST_MATCH("number of rows of matrices must match (see arg %d)"),
ROWS_NOT_MULTIPLE("number of rows of result is not a multiple of vector length (arg %d)"),
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ROptions.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ROptions.java
index 57ef75ff02d15d743aee707ceb667ca861095cca..217f27c26a90f1077c535ba181c632af226be049 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ROptions.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ROptions.java
@@ -92,9 +92,4 @@ public class ROptions {
setValue(name, value);
}
- public static void addOptions(String[] names, Object[] values) {
- for (int i = 0; i < names.length; i++) {
- map.put(names[i], values == null ? null : values[i]);
- }
- }
}
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RSerialize.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RSerialize.java
index 8e62a06caaf5180eaeaa083106f57ae7af7b475b..75daed28fa65d67dc138d334b8853b4a657d8a5c 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RSerialize.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RSerialize.java
@@ -13,6 +13,7 @@ package com.oracle.truffle.r.runtime;
import java.io.*;
+import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
import com.oracle.truffle.r.options.*;
import com.oracle.truffle.r.runtime.data.*;
import com.oracle.truffle.r.runtime.env.*;
@@ -155,6 +156,7 @@ public class RSerialize {
return trace;
}
+ @TruffleBoundary
public static Object unserialize(RConnection conn, int depth) throws IOException {
RSerialize instance = trace() ? new TracingRSerialize(conn, depth) : new RSerialize(conn, depth);
return instance.unserialize();
@@ -165,6 +167,7 @@ public class RSerialize {
* {@link #persistentRestore} is called, an R function needs to be evaluated with an argument
* read from the serialized stream. This is handled with a callback object.
*/
+ @TruffleBoundary
public static Object unserialize(byte[] data, CallHook hook, int depth) throws IOException {
InputStream is = new PByteArrayInputStream(data);
RSerialize instance = trace() ? new TracingRSerialize(is, hook, depth) : new RSerialize(is, hook, depth);
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
index 3d2462404e7642ff730aacfefdf9543878fd6ae3..6a7c191258510f20ebf25dd3b2c292ed94edd42c 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
@@ -221,23 +221,9 @@ public abstract class REnvironment extends RAttributeStorage implements RAttribu
RContext.getEngine().loadDefaultPackage("base", baseFrame.materialize(), baseEnv);
}
- public static void packagesInitialize(RStringVector rPackages) {
- // now load rPackages, we need a new VirtualFrame for each
- REnvironment pkgParent = globalEnv.parent;
- for (int i = 0; i < rPackages.getLength(); i++) {
- String pkgName = rPackages.getDataAt(i);
- if (pkgName.equals("utils") || pkgName.equals("methods") || pkgName.equals("datasets") || pkgName.equals("grDevices")) {
- continue;
- }
- VirtualFrame pkgFrame = RRuntime.createNonFunctionFrame();
- Package pkgEnv = new Package(pkgParent, pkgName, pkgFrame, REnvVars.rHome());
- RContext.getEngine().loadDefaultPackage(pkgName, pkgFrame.materialize(), pkgEnv);
- attach(2, pkgEnv);
- pkgParent = pkgEnv;
- }
- initialGlobalEnvParent = pkgParent;
+ public static void defaultPackagesInitialized() {
+ initialGlobalEnvParent = globalEnv.parent;
baseEnv.getNamespace().setParent(globalEnv);
- // set up the initial search path
}
private static void initSearchList() {
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/DLL.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/DLL.java
index 3992d42ae8640bb9b07c2c900007be991596cbf9..8ca5ce1b073fa88539a3d948b9f4a96de5d9013d 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/DLL.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/DLL.java
@@ -264,7 +264,8 @@ public class DLL {
}
/**
- * Attempts to locate a symbol in the given library.
+ * Attempts to locate a symbol in the given library. This does no filtering on registered
+ * symbols, it uses the OS level search of the library.
*/
public static SymbolInfo findSymbolInDLL(String symbol, DLLInfo dllInfo) {
boolean found = false;
@@ -293,6 +294,34 @@ public class DLL {
}
}
+ /**
+ * Similar to {@link #findSymbolInDLL(String, DLLInfo)} but restricts the search to those
+ * symbols that have been registered from packages, i.e. that can be used in {@code .Call} etc.
+ * functions.
+ */
+ public static SymbolInfo findRegisteredSymbolinInDLL(String symbol, String libName) {
+ for (DLLInfo dllInfo : list) {
+ if (libName == null || libName.length() == 0 || dllInfo.name.equals(libName)) {
+ if (dllInfo.forceSymbols) {
+ continue;
+ }
+ for (NativeSymbolType nst : NativeSymbolType.values()) {
+ DotSymbol[] dotSymbols = dllInfo.getNativeSymbols(nst);
+ if (dotSymbols == null) {
+ continue;
+ }
+ for (DotSymbol dotSymbol : dotSymbols) {
+ if (dotSymbol.name.equals(symbol)) {
+ return new SymbolInfo(dllInfo, symbol, dotSymbol.fun);
+ }
+ }
+ }
+
+ }
+ }
+ return null;
+ }
+
// Methods called from native code during library loading.
/**
@@ -327,4 +356,16 @@ public class DLL {
return old;
}
+ @SuppressWarnings("unused")
+ public static void registerCCallable(String pkgName, String functionName, long address) {
+ // TBD
+ }
+
+ @SuppressWarnings("unused")
+ public static long getCCallable(String pkgName, String functionName) {
+ // TBD
+ RInternalError.unimplemented();
+ return 0;
+ }
+
}
diff --git a/com.oracle.truffle.r.test.native/Makefile b/com.oracle.truffle.r.test.native/Makefile
index 0b7d8c02efdf7b3e1e37a93fb5b60b49f838316b..b45c0aa9c4d101896f0940ce1c99d722fd110eab 100644
--- a/com.oracle.truffle.r.test.native/Makefile
+++ b/com.oracle.truffle.r.test.native/Makefile
@@ -27,6 +27,8 @@ export TOPDIR = $(CURDIR)
all:
$(MAKE) -C urand
+ $(MAKE) -C packages
clean:
$(MAKE) -C urand clean
+ $(MAKE) -C packages clean
diff --git a/com.oracle.truffle.r.test.native/packages/Makefile b/com.oracle.truffle.r.test.native/packages/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..e40878bc0b0ecef26110d3b91ff764633ed7763a
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/Makefile
@@ -0,0 +1,41 @@
+#
+# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+.PHONY: all clean make_subdirs clean_subdirs
+
+SUBDIRS = testrffi vanilla
+
+all: make_subdirs
+
+make_subdirs:
+ for dir in $(SUBDIRS); do \
+ $(MAKE) PACKAGE=$$dir -C $$dir; \
+ done
+
+clean: clean_subdirs
+
+clean_subdirs:
+ for dir in $(SUBDIRS); do \
+ $(MAKE) PACKAGE=$$dir -C $$dir clean; \
+ done
+
diff --git a/com.oracle.truffle.r.test.native/packages/package.mk b/com.oracle.truffle.r.test.native/packages/package.mk
new file mode 100644
index 0000000000000000000000000000000000000000..a0eac0052b10f60a67810ba7eb96833f344dfdab
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/package.mk
@@ -0,0 +1,44 @@
+#
+# Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+# This "builds" a test package, resulting in a tar file,
+# which is then loaded by the unit tests in TestRPackages.
+# Note that the tar file root must be a single directoru but
+# the name is unimportant because the install process takes the
+# package name from the DESCRIPTION. So we just use the "src" directory.
+
+.PHONY: all
+
+PKG_FILES = $(shell find src/ -type f -name '*')
+
+PKG_TAR = lib/$(PACKAGE).tar
+
+all: $(PKG_TAR)
+
+$(PKG_TAR): $(PKG_FILES)
+ mkdir -p lib
+ tar cf $(PKG_TAR) src
+
+clean:
+ rm -f $(PKG_TAR)
+
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/Makefile b/com.oracle.truffle.r.test.native/packages/testrffi/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..53e31d838c9ca1c98f116c218f30e5f6d284b083
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/Makefile
@@ -0,0 +1,24 @@
+#
+# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+include ../package.mk
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/lib/testrffi.tar b/com.oracle.truffle.r.test.native/packages/testrffi/lib/testrffi.tar
new file mode 100644
index 0000000000000000000000000000000000000000..052aebe01fad17a0ce01ac8141bc54a374efb348
Binary files /dev/null and b/com.oracle.truffle.r.test.native/packages/testrffi/lib/testrffi.tar differ
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/DESCRIPTION b/com.oracle.truffle.r.test.native/packages/testrffi/src/DESCRIPTION
new file mode 100644
index 0000000000000000000000000000000000000000..37a90e17213ee9c85e6dd0b8b0b6459f6f4f191d
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/DESCRIPTION
@@ -0,0 +1,10 @@
+Package: testrffi
+Type: Package
+Title: Tests a package with native code
+Version: 1.0
+Date: 2014-08-21
+Author: FastR Tester
+Maintainer: FastR Tester <fastr@yahoogroups.com>
+Description: Tests a package with native code
+License: GPL-2
+Packaged: 2014-08-27 22:48:32 UTC; mjjordan
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/NAMESPACE b/com.oracle.truffle.r.test.native/packages/testrffi/src/NAMESPACE
new file mode 100644
index 0000000000000000000000000000000000000000..6a46a89ac9f4628aef1b3fce98306a8f9cc26d08
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/NAMESPACE
@@ -0,0 +1,7 @@
+## package has a dynamic library
+useDynLib(testrffi)
+
+## and exported functions
+export(add_int)
+export(add_double)
+export(createIntVector)
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/R/testrffi.R b/com.oracle.truffle.r.test.native/packages/testrffi/src/R/testrffi.R
new file mode 100644
index 0000000000000000000000000000000000000000..1dfb43aea4bb3ace45ad298abf945f5eec3c1cf1
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/R/testrffi.R
@@ -0,0 +1,11 @@
+add_int <- function(a, b) {
+ .Call("add_int", as.integer(a), as.integer(b), PACKAGE = "testrffi")
+}
+
+add_double <- function(a, b) {
+ .Call("add_double", as.double(a), as.double(b), PACKAGE = "testrffi")
+}
+
+createIntVector <- function(n) {
+ .Call("createIntVector", as.integer(n), PACKAGE = "testrffi")
+}
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi-package.Rd b/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi-package.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f73ed8ca85e6ac0d9221cebacac42d104f2bb3d6
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi-package.Rd
@@ -0,0 +1,31 @@
+\name{testrffi-package}
+\alias{testrffi-package}
+\alias{testrffi}
+\docType{package}
+\title{Tests a package with native code}
+\description{Tests a package with native code}
+\details{
+\tabular{ll}{
+Package: \tab testrffi\cr
+Type: \tab Package\cr
+Version: \tab 1.0\cr
+Date: \tab 2014-08-21\cr
+License: \tab GPL-2\cr
+}
+
+}
+\author{
+The FastR Team
+
+Maintainer: fastr@yahoogroups.com
+}
+\references{
+}
+
+\keyword{ package }
+\seealso{
+
+}
+\examples{
+
+}
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi.Rd b/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..edb39851ba94c1d1f1dcf3d2f49958f85ab2f70e
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/man/testrffi.Rd
@@ -0,0 +1,35 @@
+\name{testrffi}
+\alias{testrffi}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+testrffi
+}
+\description{
+Tests the R FFI interface
+}
+\usage{
+addint(2,3)
+}
+
+\details{
+
+}
+\value{
+invisble NULL
+}
+\references{
+
+}
+\author{
+FastR Team
+}
+\note{
+
+}
+
+\seealso{
+%
+}
+\examples{
+addint(2,3)
+}
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/src/Makefile b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..4a67ee84de8830ba776c885e8e62da285d4b1958
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/Makefile
@@ -0,0 +1,57 @@
+#
+# Copyright (c) 2014, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+.PHONY: all clean
+
+C_SOURCES := $(wildcard *.c)
+# R uses the .so extension on Mac OS X
+C_OBJECTS := $(C_SOURCES:.c=.o)
+C_LIB := testrffi.so
+
+NATIVE_PROJECT=$(FASTR_HOME)/com.oracle.truffle.r.native
+include $(NATIVE_PROJECT)/platform.mk
+
+ifeq ($(FASTR_INSTALL), GNUR)
+ INCLUDES := -I $(R_HOME)/include
+ ifeq ($(OSNAME), Darwin)
+ FRAMEWORKFLAGS := -F${R_HOME}/../.. -framework R
+ else
+ FRAMEWORKFLAGS :=
+ endif
+ LDFLAGS := $(LDFLAGS) $(FRAMEWORKFLAGS)
+else
+ INCLUDES := -I $(NATIVE_PROJECT)/include/jni -I $(FASTR_JAVA_HOME)/include -I $(FASTR_JAVA_HOME)/include/$(OS_DIR)
+endif
+
+
+all: $(C_LIB)
+
+$(C_LIB): $(C_OBJECTS)
+ $(CC) $(LDFLAGS) -o $(C_LIB) $(C_OBJECTS)
+
+%.o: %.c
+ $(CC) $(CFLAGS) $(INCLUDES) -c $< -o $@
+
+clean:
+ rm $(C_LIB) $(C_OBJECTS)
+
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/src/src/init.c b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/init.c
new file mode 100644
index 0000000000000000000000000000000000000000..4fc07a8842d33f99074a0d4f3469439a53043eee
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/init.c
@@ -0,0 +1,10 @@
+#include <R.h>
+#include <Rinternals.h>
+
+#include <R_ext/Rdynload.h>
+
+void
+R_init_testrffi(DllInfo *dll)
+{
+ R_registerRoutines(dll, NULL, NULL, NULL, NULL);
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsPackage.java b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/testrffi.c
similarity index 64%
rename from com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsPackage.java
rename to com.oracle.truffle.r.test.native/packages/testrffi/src/src/testrffi.c
index 79e427c92a445ff9d4282f9604a797ad92a0bf09..0ce7071e72f4603573d2cd3bc0d655f3e4a589e4 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsPackage.java
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/src/src/testrffi.c
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2014, 2014, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
*
* This code is free software; you can redistribute it and/or modify it
@@ -20,19 +20,26 @@
* or visit www.oracle.com if you need additional information or have any
* questions.
*/
-package com.oracle.truffle.r.nodes.builtin.stats;
-import com.oracle.truffle.r.nodes.builtin.*;
+// A very simple test of the R FFI interface
-public class StatsPackage extends RBuiltinPackage {
+#include <R.h>
+#include <Rdefines.h>
+#include <Rinternals.h>
- public StatsPackage() {
- loadBuiltins();
- }
+SEXP add_int(SEXP a, SEXP b) {
+ int aInt = INTEGER_VALUE(a);
+ int bInt = INTEGER_VALUE(b);
+ return ScalarInteger(aInt + bInt);
+}
- @Override
- public String getName() {
- return "stats";
- }
+SEXP add_double(SEXP a, SEXP b) {
+ double aDouble = NUMERIC_VALUE(a);
+ double bDouble = NUMERIC_VALUE(b);
+ return ScalarReal(aDouble + bDouble);
+}
+SEXP createIntVector(SEXP n) {
+ SEXP v = allocVector(INTSXP, INTEGER_VALUE(n));
+ return v;
}
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/Makefile b/com.oracle.truffle.r.test.native/packages/vanilla/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..53e31d838c9ca1c98f116c218f30e5f6d284b083
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/Makefile
@@ -0,0 +1,24 @@
+#
+# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+include ../package.mk
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/lib/vanilla.tar b/com.oracle.truffle.r.test.native/packages/vanilla/lib/vanilla.tar
new file mode 100644
index 0000000000000000000000000000000000000000..e37d5034eb5bf33e3315c02253e76cd6a48b7976
Binary files /dev/null and b/com.oracle.truffle.r.test.native/packages/vanilla/lib/vanilla.tar differ
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/src/DESCRIPTION b/com.oracle.truffle.r.test.native/packages/vanilla/src/DESCRIPTION
new file mode 100644
index 0000000000000000000000000000000000000000..f242f23dbbd6987d45cc46983393da75877cc570
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/src/DESCRIPTION
@@ -0,0 +1,10 @@
+Package: vanilla
+Type: Package
+Title: Tests the package loading implementation
+Version: 1.0
+Date: 2014-08-21
+Author: FastR Tester
+Maintainer: FastR Tester <fastr@yahoogroups.com>
+Description: Tests the package loading implementation
+License: GPL-2
+Packaged: 2014-08-22 00:34:45 UTC; mjj
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/src/NAMESPACE b/com.oracle.truffle.r.test.native/packages/vanilla/src/NAMESPACE
new file mode 100644
index 0000000000000000000000000000000000000000..16685286e4092711ae3bacc843642d89607952a5
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/src/NAMESPACE
@@ -0,0 +1 @@
+export(vanilla)
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/src/R/vanilla.R b/com.oracle.truffle.r.test.native/packages/vanilla/src/R/vanilla.R
new file mode 100644
index 0000000000000000000000000000000000000000..19c05192f9379132a6c4b0108ee793de543305d3
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/src/R/vanilla.R
@@ -0,0 +1,2 @@
+vanilla <-
+function() print("A vanilla R package")
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla-package.Rd b/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla-package.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6eb09347288037adc989fefb0e401917fd6690b6
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla-package.Rd
@@ -0,0 +1,31 @@
+\name{vanilla-package}
+\alias{vanilla-package}
+\alias{vanilla}
+\docType{package}
+\title{Tests the package loading implementation}
+\description{Tests the package loading implementation}
+\details{
+\tabular{ll}{
+Package: \tab vanilla\cr
+Type: \tab Package\cr
+Version: \tab 1.0\cr
+Date: \tab 2014-08-21\cr
+License: \tab GPL-2\cr
+}
+
+}
+\author{
+The FastR Team
+
+Maintainer: fastr@yahoogroups.com
+}
+\references{
+}
+
+\keyword{ package }
+\seealso{
+
+}
+\examples{
+
+}
diff --git a/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla.Rd b/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..21eb5aea52a0a02c81da888f0f2b011a8a8fa4c5
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/packages/vanilla/src/man/vanilla.Rd
@@ -0,0 +1,35 @@
+\name{vanilla}
+\alias{vanilla}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+vanilla
+}
+\description{
+prints A vaniila R package
+}
+\usage{
+vanilla()
+}
+
+\details{
+
+}
+\value{
+invisble NULL
+}
+\references{
+
+}
+\author{
+FastR Team
+}
+\note{
+
+}
+
+\seealso{
+%
+}
+\examples{
+vanilla()
+}
diff --git a/com.oracle.truffle.r.test/rpackages/distributions/testrffi_1.0.tar.gz b/com.oracle.truffle.r.test/rpackages/distributions/testrffi_1.0.tar.gz
deleted file mode 100644
index e84709e0f71cfabff83cd65354aa8750ca6021e9..0000000000000000000000000000000000000000
Binary files a/com.oracle.truffle.r.test/rpackages/distributions/testrffi_1.0.tar.gz and /dev/null differ
diff --git a/com.oracle.truffle.r.test/rpackages/distributions/vanilla_1.0.tar.gz b/com.oracle.truffle.r.test/rpackages/distributions/vanilla_1.0.tar.gz
deleted file mode 100644
index e956115dbec0a4d62d1b722ebd7fcf790f5e6240..0000000000000000000000000000000000000000
Binary files a/com.oracle.truffle.r.test/rpackages/distributions/vanilla_1.0.tar.gz and /dev/null differ
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/rpackages/TestRPackages.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/rpackages/TestRPackages.java
index 272af7564e6015ea2fc861ae845cb0e3a4d20df3..f08e5eed00a01377bcb1bd70b8ad3224d9cab47d 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/rpackages/TestRPackages.java
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/rpackages/TestRPackages.java
@@ -44,11 +44,18 @@ public class TestRPackages extends TestBase {
* in the test string. So the install is destructive, but ok as there is never a clash.
*
* Currently we are using GnuR to do the install of the FastR-compiled package. The install
- * environment is handled in the Makefile using environment variables set in
- * {@link #installPackage(String)}.
+ * environment for packageds with nativge code is handled in the Makefile using environment
+ * variables set in {@link #installPackage(String)}.
*/
private static final class PackagePaths {
+ /**
+ * The path containing the package distributions as tar files. These are built in the
+ * {@code com.oracle.truffle.r.test.native} project in the {@code packages} directory.
+ */
private final Path rpackagesDists;
+ /**
+ * The path to where the package will be installed (R_LIBS_USER).
+ */
private final Path rpackagesLibs;
private PackagePaths() {
@@ -57,11 +64,11 @@ public class TestRPackages extends TestBase {
if (!rpackagesLibs.toFile().exists()) {
rpackagesLibs.toFile().mkdir();
}
- rpackagesDists = rpackages.resolve("distributions");
+ rpackagesDists = Paths.get(REnvVars.rHome(), "com.oracle.truffle.r.test.native", "packages");
}
- private boolean installPackage(String packageZip) {
- Path packagePath = rpackagesDists.resolve(packageZip);
+ private boolean installPackage(String packageName) {
+ Path packagePath = rpackagesDists.resolve(packageName).resolve("lib").resolve(packageName + ".tar");
// install the package (using GnuR for now)
ProcessBuilder pb = new ProcessBuilder("R", "CMD", "INSTALL", packagePath.toString());
Map<String, String> env = pb.environment();
@@ -84,8 +91,7 @@ public class TestRPackages extends TestBase {
}
}
- private boolean uninstallPackage(String packageZip) {
- String packageName = packageZip.substring(0, packageZip.indexOf('_'));
+ private boolean uninstallPackage(String packageName) {
Path packageDir = rpackagesLibs.resolve(packageName);
try {
Files.walkFileTree(packageDir, DELETE_VISITOR);
@@ -119,7 +125,7 @@ public class TestRPackages extends TestBase {
private static final PackagePaths packagePaths = new PackagePaths();
- private static final String[] TEST_PACKAGES = new String[]{"vanilla_1.0.tar.gz", "testrffi_1.0.tar.gz"};
+ private static final String[] TEST_PACKAGES = new String[]{"vanilla", "testrffi"};
@BeforeClass
public static void setupInstallTestPackages() {
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/simple/TestSimpleBuiltins.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/simple/TestSimpleBuiltins.java
index 4514533592b37132501e5804ff3bbadcdc282cf7..585493bff96b5dc4a9a6b8b1f0ea55cdc570addc 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/simple/TestSimpleBuiltins.java
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/simple/TestSimpleBuiltins.java
@@ -2499,7 +2499,7 @@ public class TestSimpleBuiltins extends TestBase {
assertEval("{ cor(c(1,2,3),c(1,2,3)) }");
assertEval("{ as.integer(cor(c(1,2,3),c(1,2,5))*10000000) }");
assertEval("{ cor(cbind(c(3,2,1), c(1,2,3))) }");
- assertEval("{ cor(cbind(c(1, 1, 1), c(1, 1, 1))) }");
+ assertEvalWarning("{ cor(cbind(c(1, 1, 1), c(1, 1, 1))) }");
assertEval("{ cor(cbind(c(1:9,0/0), 101:110)) }");
assertEval("{ round( cor(cbind(c(10,5,4,1), c(2,5,10,5))), digits=5 ) }");
}
diff --git a/mx.fastr/copyrights/gnu_r_statsutil.copyright.star b/mx.fastr/copyrights/gnu_r_ihaka.copyright.star
similarity index 100%
rename from mx.fastr/copyrights/gnu_r_statsutil.copyright.star
rename to mx.fastr/copyrights/gnu_r_ihaka.copyright.star
diff --git a/mx.fastr/copyrights/gnu_r_statsutil.copyright.star.regex b/mx.fastr/copyrights/gnu_r_ihaka.copyright.star.regex
similarity index 100%
rename from mx.fastr/copyrights/gnu_r_statsutil.copyright.star.regex
rename to mx.fastr/copyrights/gnu_r_ihaka.copyright.star.regex
diff --git a/mx.fastr/copyrights/overrides b/mx.fastr/copyrights/overrides
index 38adf30475668da88e3206773ffb0e9690b2e198..850915b041686eeb0d8d334c6010692c102ee26a 100644
--- a/mx.fastr/copyrights/overrides
+++ b/mx.fastr/copyrights/overrides
@@ -6,19 +6,39 @@ com.oracle.truffle.r.native/include/jni/R_ext/Boolean.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Complex.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Constants.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Error.h,no.copyright
+com.oracle.truffle.r.native/include/jni/R_ext/GraphicsDevice.h,no.copyright
+com.oracle.truffle.r.native/include/jni/R_ext/GraphicsEngine.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/libextern.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Memory.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Print.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Random.h,no.copyright
+com.oracle.truffle.r.native/include/jni/R_ext/Rdynload.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/RS.h,no.copyright
com.oracle.truffle.r.native/include/jni/R_ext/Utils.h,no.copyright
+com.oracle.truffle.r.native/include/jni/R_ext/Visibility.h,no.copyright
+com.oracle.truffle.r.native/include/jni/libintl.h,no.copyright
com.oracle.truffle.r.native/include/jni/R.h,no.copyright
com.oracle.truffle.r.native/include/jni/Rconfig.h,no.copyright
com.oracle.truffle.r.native/include/jni/Rdefines.h,no.copyright
com.oracle.truffle.r.native/include/jni/Rinternals.h,gnu_r.copyright
-com.oracle.truffle.r.native/library/tools/src/tools.c,no.copyright
-com.oracle.truffle.r.native/library/utils/src/utils.c,no.copyright
-com.oracle.truffle.r.native/library/methods/src/methods.c,no.copyright
+com.oracle.truffle.r.native/library/graphics/src/graphics.h,no.copyright
+com.oracle.truffle.r.native/library/graphics/src/init.c,no.copyright
+com.oracle.truffle.r.native/library/grDevices/src/grDevices.h,no.copyright
+com.oracle.truffle.r.native/library/grDevices/src/init.c,no.copyright
+com.oracle.truffle.r.native/library/grDevices/src/devQuartz.c,no.copyright
+com.oracle.truffle.r.native/library/methods/src/methods.h,no.copyright
+com.oracle.truffle.r.native/library/methods/src/init.c,no.copyright
+com.oracle.truffle.r.native/library/stats/src/stats.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/modreg.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/nls.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/port.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/statsR.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/ts.h,no.copyright
+com.oracle.truffle.r.native/library/stats/src/init.c,no.copyright
+com.oracle.truffle.r.native/library/tools/src/tools.h,no.copyright
+com.oracle.truffle.r.native/library/tools/src/init.c,no.copyright
+com.oracle.truffle.r.native/library/utils/src/utils.h,no.copyright
+com.oracle.truffle.r.native/library/utils/src/init.c,no.copyright
com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/BinaryOpsGroupDispatchNode.java,purdue.copyright
com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/DispatchNode.java,purdue.copyright
com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/DispatchedCallNode.java,purdue.copyright
@@ -37,8 +57,8 @@ com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/unary/InheritsNode.jav
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DuplicatedFunctions.java,purdue.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/APerm.java,purdue.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Base.r,gnu_r.copyright
+com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/BaseGammaFunctions.r,gnu_r_ihaka.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/CharMatch.java,purdue.copyright
-com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Covcor.java,gnu_r.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/CumProd.java,purdue.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/ColMeans.java,purdue.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/CumMax.java,purdue.copyright
@@ -74,11 +94,11 @@ com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/L
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Switch.java,purdue.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/Format.java,gnu_r.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/methods/MethodListDispatch.java,gnu_r.copyright
-com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Rnorm.java,gnu_r.copyright
+com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Covcor.java,gnu_r.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/GammaFunctions.java,gnu_r_qgamma.copyright
+com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/Rnorm.java,gnu_r.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/SplineFunctions.java,gnu_r_splines.copyright
-com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsUtil.java,gnu_r_statsutil.copyright
-com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/utils/CountFields.java,gnu_r.copyright
+com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/stats/StatsUtil.java,gnu_r_ihaka.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/utils/CountFields.java,gnu_r.copyright
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/utils/WriteTable.java,gnu_r.copyright
com.oracle.truffle.r.parser/src/com/oracle/truffle/r/parser/ParseException.java,purdue.copyright