diff --git a/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grid/GridFunctions.java b/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grid/GridFunctions.java
index a8baa1e76adff364388f43b6886798a4c25d58b7..78338d6c6cc4335ed97664ba2bcbe401287e6105 100644
--- a/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grid/GridFunctions.java
+++ b/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grid/GridFunctions.java
@@ -1,31 +1,27 @@
/*
- * Copyright (c) 2015, 2016, Oracle and/or its affiliates. All rights reserved.
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+ * 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
*
- * 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.
+ * Copyright (C) 2001-3 Paul Murrell
+ * Copyright (c) 1998-2013, The R Core Team
+ * Copyright (c) 2013, 2016, Oracle and/or its affiliates
*
- * 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.
+ * All rights reserved.
*/
package com.oracle.truffle.r.library.grid;
+import static com.oracle.truffle.r.nodes.builtin.CastBuilder.Predef.notEmpty;
+import static com.oracle.truffle.r.nodes.builtin.CastBuilder.Predef.stringValue;
import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
import com.oracle.truffle.api.dsl.Specialization;
+import com.oracle.truffle.r.nodes.builtin.CastBuilder;
import com.oracle.truffle.r.nodes.builtin.RExternalBuiltinNode;
+import com.oracle.truffle.r.runtime.RError;
import com.oracle.truffle.r.runtime.data.RArgsValuesAndNames;
+import com.oracle.truffle.r.runtime.data.RDataFactory;
+import com.oracle.truffle.r.runtime.data.RIntVector;
+import com.oracle.truffle.r.runtime.data.model.RAbstractStringVector;
import com.oracle.truffle.r.runtime.env.REnvironment;
import com.oracle.truffle.r.runtime.ffi.RFFIFactory;
@@ -48,4 +44,43 @@ public class GridFunctions {
return RFFIFactory.getRFFI().getGridRFFI().killGrid();
}
}
+
+ public abstract static class ValidUnits extends RExternalBuiltinNode.Arg1 {
+ @Override
+ protected void createCasts(CastBuilder casts) {
+ casts.arg(0).mustBe(stringValue(), RError.Message.GENERIC, "'units' must be character").asStringVector().mustBe(notEmpty(), RError.Message.GENERIC, "'units' must be of length > 0");
+ }
+
+ @Specialization
+ protected RIntVector validUnits(RAbstractStringVector units) {
+ int[] data = new int[units.getLength()];
+ for (int i = 0; i < data.length; i++) {
+ int code = convertUnit(units.getDataAt(i));
+ if (code < 0) {
+ throw RError.error(this, RError.Message.GENERIC, "Invalid unit");
+ }
+ data[i] = code;
+ }
+ return RDataFactory.createIntVector(data, RDataFactory.COMPLETE_VECTOR);
+ }
+
+ private enum UnitTab {
+ npc(0);
+
+ private final int code;
+
+ UnitTab(int code) {
+ this.code = code;
+ }
+ }
+
+ private static int convertUnit(String unit) {
+ for (UnitTab unitTab : UnitTab.values()) {
+ if (unit.equals(unitTab.name())) {
+ return unitTab.code;
+ }
+ }
+ return -1;
+ }
+ }
}
diff --git a/com.oracle.truffle.r.native/gnur/patchXzMakefile b/com.oracle.truffle.r.native/gnur/patchXzMakefile
deleted file mode 100644
index ade46f7204cff323fc8e03b1401c4d3101260480..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/gnur/patchXzMakefile
+++ /dev/null
@@ -1,3 +0,0 @@
-/\$rm -f/s/\$rm/@rm/
-w
-q
diff --git a/com.oracle.truffle.r.native/library/grid/Makefile b/com.oracle.truffle.r.native/library/grid/Makefile
index f128fcf8a4ea847d045bd6a86eda6d24ffe6ae27..58f1789a96f7caa5c52cb451e834c8d46302b4de 100644
--- a/com.oracle.truffle.r.native/library/grid/Makefile
+++ b/com.oracle.truffle.r.native/library/grid/Makefile
@@ -1,5 +1,5 @@
#
-# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2014, 2016, 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
@@ -21,4 +21,14 @@
# questions.
#
+OBJ = lib
+
+GNUR_C_FILES := $(notdir $(wildcard $(GNUR_HOME)/src/library/grid/src/*.c))
+
+GNUR_C_OBJECTS := $(addprefix $(OBJ)/, $(GNUR_C_FILES:.c=.o))
+#$(info GNUR_C_OBJECTS=$(GNUR_C_OBJECTS))
+
include ../lib.mk
+
+$(OBJ)/%.o: $(GNUR_SRC)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(SUPPRESS_WARNINGS) -c $< -o $@
diff --git a/com.oracle.truffle.r.native/library/grid/src/gpar.c b/com.oracle.truffle.r.native/library/grid/src/gpar.c
deleted file mode 100644
index e98b81e902dfa826d88ab39e060287cd64a38f40..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/gpar.c
+++ /dev/null
@@ -1,348 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003 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/
- */
-
-#include "grid.h"
-#include <string.h>
-
-
-extern int gridRegisterIndex;
-
-/* Some access methods for gpars */
-SEXP gpFontSizeSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_FONTSIZE);
-}
-
-double gpFontSize(SEXP gp, int i) {
- SEXP fontsize = gpFontSizeSXP(gp);
- return REAL(fontsize)[i % LENGTH(fontsize)];
-}
-
-SEXP gpLineHeightSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LINEHEIGHT);
-}
-
-double gpLineHeight(SEXP gp, int i) {
- SEXP lineheight = gpLineHeightSXP(gp);
- return REAL(lineheight)[i % LENGTH(lineheight)];
-}
-
-/* grid has no concept of 'colour 0' (bg in base) */
-int gpCol(SEXP gp, int i) {
- SEXP col = VECTOR_ELT(gp, GP_COL);
- int result;
- if (isNull(col))
- result = R_TRANWHITE;
- else
- result = RGBpar3(col, i % LENGTH(col), R_TRANWHITE);
- return result;
-}
-
-SEXP gpFillSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_FILL);
-}
-
-int gpFill(SEXP gp, int i) {
- SEXP fill = gpFillSXP(gp);
- int result;
- if (isNull(fill))
- result = R_TRANWHITE;
- else
- result = RGBpar3(fill, i % LENGTH(fill), R_TRANWHITE);
- return result;
-}
-
-SEXP gpGammaSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_GAMMA);
-}
-
-double gpGamma(SEXP gp, int i) {
- SEXP gamma = gpGammaSXP(gp);
- return REAL(gamma)[i % LENGTH(gamma)];
-}
-
-SEXP gpLineTypeSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LTY);
-}
-
-int gpLineType(SEXP gp, int i) {
- SEXP linetype = gpLineTypeSXP(gp);
- return GE_LTYpar(linetype, i % LENGTH(linetype));
-}
-
-SEXP gpLineWidthSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LWD);
-}
-
-double gpLineWidth(SEXP gp, int i) {
- SEXP linewidth = gpLineWidthSXP(gp);
- return REAL(linewidth)[i % LENGTH(linewidth)];
-}
-
-SEXP gpCexSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_CEX);
-}
-
-double gpCex(SEXP gp, int i) {
- SEXP cex = gpCexSXP(gp);
- return REAL(cex)[i % LENGTH(cex)];
-}
-
-SEXP gpFontSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_FONT);
-}
-
-int gpFont(SEXP gp, int i) {
- SEXP font = gpFontSXP(gp);
- return INTEGER(font)[i % LENGTH(font)];
-}
-
-SEXP gpFontFamilySXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_FONTFAMILY);
-}
-
-const char* gpFontFamily(SEXP gp, int i) {
- SEXP fontfamily = gpFontFamilySXP(gp);
- return CHAR(STRING_ELT(fontfamily, i % LENGTH(fontfamily)));
-}
-
-SEXP gpAlphaSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_ALPHA);
-}
-
-double gpAlpha(SEXP gp, int i) {
- SEXP alpha = gpAlphaSXP(gp);
- return REAL(alpha)[i % LENGTH(alpha)];
-}
-
-SEXP gpLineEndSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LINEEND);
-}
-
-R_GE_lineend gpLineEnd(SEXP gp, int i) {
- SEXP lineend = gpLineEndSXP(gp);
- return GE_LENDpar(lineend, i % LENGTH(lineend));
-}
-
-SEXP gpLineJoinSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LINEJOIN);
-}
-
-R_GE_linejoin gpLineJoin(SEXP gp, int i) {
- SEXP linejoin = gpLineJoinSXP(gp);
- return GE_LJOINpar(linejoin, i % LENGTH(linejoin));
-}
-
-SEXP gpLineMitreSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LINEMITRE);
-}
-
-double gpLineMitre(SEXP gp, int i) {
- SEXP linemitre = gpLineMitreSXP(gp);
- return REAL(linemitre)[i % LENGTH(linemitre)];
-}
-
-SEXP gpLexSXP(SEXP gp) {
- return VECTOR_ELT(gp, GP_LEX);
-}
-
-double gpLex(SEXP gp, int i) {
- SEXP lex = gpLexSXP(gp);
- return REAL(lex)[i % LENGTH(lex)];
-}
-
-/*
- * Never access fontface because fontface values are stored in font
- * Historical reasons ...
- */
-
-/*
- * Combine gpar alpha with alpha level stored in colour
- *
- * finalAlpha = gpAlpha*(R_ALPHA(col)/255)
- *
- * Based on my reading of how group alpha and individual
- * object alphas are combined in the SVG 1.0 docs
- *
- * Also has nice properties:
- * (i) range of finalAlpha is 0 to 1.
- * (ii) if either of gpAlpha or R_ALPHA(col) are 0 then finalAlpha = 0
- * (i.e., can never make fully transparent colour less transparent).
- * (iii) in order to get finalAlpha = 1, both gpAlpha and R_ALPHA(col)
- * must be 1 (i.e., only way to get fully opaque is if both
- * alpha levels are fully opaque).
- */
-static unsigned int combineAlpha(double alpha, int col)
-{
- unsigned int newAlpha = (unsigned int)((alpha*(R_ALPHA(col)/255.0))*255);
- return R_RGBA(R_RED(col), R_GREEN(col), R_BLUE(col), newAlpha);
-}
-
-/*
- * Generate an R_GE_gcontext from a gpar
- */
-void gcontextFromgpar(SEXP gp, int i, const pGEcontext gc, pGEDevDesc dd)
-{
- /*
- * Combine gpAlpha with col and fill
- */
- gc->col = combineAlpha(gpAlpha(gp, i), gpCol(gp, i));
- gc->fill = combineAlpha(gpAlpha(gp, i), gpFill(gp, i));
- gc->gamma = gpGamma(gp, i);
- /*
- * Combine gpLex with lwd
- * Also scale by GSS_SCALE (a "zoom" factor)
- */
- gc->lwd = gpLineWidth(gp, i) * gpLex(gp, i) *
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- gc->lty = gpLineType(gp, i);
- gc->lend = gpLineEnd(gp, i);
- gc->ljoin = gpLineJoin(gp, i);
- gc->lmitre = gpLineMitre(gp, i);
- gc->cex = gpCex(gp, i);
- /*
- * Scale by GSS_SCALE (a "zoom" factor)
- */
- gc->ps = gpFontSize(gp, i) * REAL(gridStateElement(dd, GSS_SCALE))[0];
- gc->lineheight = gpLineHeight(gp, i);
- gc->fontface = gpFont(gp, i);
- strcpy(gc->fontfamily, gpFontFamily(gp, i));
-}
-
-SEXP L_setGPar(SEXP gpars)
-{
- /* Set the value of the current gpars on the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_GPAR, gpars);
- return R_NilValue;
-}
-
-SEXP L_getGPar(void)
-{
- /* Get the value of the current gpars on the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_GPAR);
-}
-
-SEXP L_getGPsaved()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_GPSAVED);
-}
-
-SEXP L_setGPsaved(SEXP gpars)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_GPSAVED, gpars);
- return R_NilValue;
-}
-
-void initGPar(pGEDevDesc dd)
-{
- pDevDesc dev = dd->dev;
- SEXP gpar, gparnames, class;
- SEXP gpfill, gpcol, gpgamma, gplty, gplwd, gpcex, gpfs, gplh, gpfont;
- SEXP gpfontfamily, gpalpha, gplineend, gplinejoin, gplinemitre, gplex;
- SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- PROTECT(gpar = allocVector(VECSXP, 15));
- PROTECT(gparnames = allocVector(STRSXP, 15));
- SET_STRING_ELT(gparnames, GP_FILL, mkChar("fill"));
- SET_STRING_ELT(gparnames, GP_COL, mkChar("col"));
- SET_STRING_ELT(gparnames, GP_GAMMA, mkChar("gamma"));
- SET_STRING_ELT(gparnames, GP_LTY, mkChar("lty"));
- SET_STRING_ELT(gparnames, GP_LWD, mkChar("lwd"));
- SET_STRING_ELT(gparnames, GP_CEX, mkChar("cex"));
- SET_STRING_ELT(gparnames, GP_FONTSIZE, mkChar("fontsize"));
- SET_STRING_ELT(gparnames, GP_LINEHEIGHT, mkChar("lineheight"));
- SET_STRING_ELT(gparnames, GP_FONT, mkChar("font"));
- SET_STRING_ELT(gparnames, GP_FONTFAMILY, mkChar("fontfamily"));
- SET_STRING_ELT(gparnames, GP_ALPHA, mkChar("alpha"));
- SET_STRING_ELT(gparnames, GP_LINEEND, mkChar("lineend"));
- SET_STRING_ELT(gparnames, GP_LINEJOIN, mkChar("linejoin"));
- SET_STRING_ELT(gparnames, GP_LINEMITRE, mkChar("linemitre"));
- SET_STRING_ELT(gparnames, GP_LEX, mkChar("lex"));
- setAttrib(gpar, R_NamesSymbol, gparnames);
- PROTECT(gpfill = allocVector(STRSXP, 1));
- SET_STRING_ELT(gpfill, 0, mkChar(col2name(dev->startfill)));
- SET_VECTOR_ELT(gpar, GP_FILL, gpfill);
- PROTECT(gpcol = allocVector(STRSXP, 1));
- SET_STRING_ELT(gpcol, 0, mkChar(col2name(dev->startcol)));
- SET_VECTOR_ELT(gpar, GP_COL, gpcol);
- PROTECT(gpgamma = allocVector(REALSXP, 1));
- REAL(gpgamma)[0] = dev->startgamma;
- SET_VECTOR_ELT(gpar, GP_GAMMA, gpgamma);
- PROTECT(gplty = GE_LTYget(dev->startlty));
- SET_VECTOR_ELT(gpar, GP_LTY, gplty);
- PROTECT(gplwd = allocVector(REALSXP, 1));
- REAL(gplwd)[0] = 1;
- SET_VECTOR_ELT(gpar, GP_LWD, gplwd);
- PROTECT(gpcex = allocVector(REALSXP, 1));
- REAL(gpcex)[0] = 1;
- SET_VECTOR_ELT(gpar, GP_CEX, gpcex);
- PROTECT(gpfs = allocVector(REALSXP, 1));
- REAL(gpfs)[0] = dev->startps;
- SET_VECTOR_ELT(gpar, GP_FONTSIZE, gpfs);
- PROTECT(gplh = allocVector(REALSXP, 1));
- REAL(gplh)[0] = 1.2;
- SET_VECTOR_ELT(gpar, GP_LINEHEIGHT, gplh);
- PROTECT(gpfont = allocVector(INTSXP, 1));
- INTEGER(gpfont)[0] = dev->startfont;
- SET_VECTOR_ELT(gpar, GP_FONT, gpfont);
- PROTECT(gpfontfamily = allocVector(STRSXP, 1));
- /*
- * A font family of "" means that the default font
- * set up by the device will be used.
- */
- SET_STRING_ELT(gpfontfamily, 0, mkChar(""));
- SET_VECTOR_ELT(gpar, GP_FONTFAMILY, gpfontfamily);
- PROTECT(gpalpha = allocVector(REALSXP, 1));
- REAL(gpalpha)[0] = 1;
- SET_VECTOR_ELT(gpar, GP_ALPHA, gpalpha);
- PROTECT(gplineend = allocVector(STRSXP, 1));
- SET_STRING_ELT(gplineend, 0, mkChar("round"));
- SET_VECTOR_ELT(gpar, GP_LINEEND, gplineend);
- PROTECT(gplinejoin = allocVector(STRSXP, 1));
- SET_STRING_ELT(gplinejoin, 0, mkChar("round"));
- SET_VECTOR_ELT(gpar, GP_LINEJOIN, gplinejoin);
- PROTECT(gplinemitre = allocVector(REALSXP, 1));
- REAL(gplinemitre)[0] = 10;
- SET_VECTOR_ELT(gpar, GP_LINEMITRE, gplinemitre);
- PROTECT(gplex = allocVector(REALSXP, 1));
- REAL(gplex)[0] = 1;
- SET_VECTOR_ELT(gpar, GP_LEX, gplex);
- PROTECT(class = allocVector(STRSXP, 1));
- SET_STRING_ELT(class, 0, mkChar("gpar"));
- classgets(gpar, class);
- SET_VECTOR_ELT(gsd, GSS_GPAR, gpar);
- UNPROTECT(18);
-}
diff --git a/com.oracle.truffle.r.native/library/grid/src/grid.c b/com.oracle.truffle.r.native/library/grid/src/grid.c
deleted file mode 100644
index c04bd2e4fc3aacf0dc6d7e032397de1ff1734e1c..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/grid.c
+++ /dev/null
@@ -1,3694 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-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.
- *
- * 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/
- */
-
-
-#define GRID_MAIN
-#include "grid.h"
-#include <math.h>
-#include <float.h>
-#include <string.h>
-
-/* NOTE:
- * The extensive use of L or L_ prefixes dates back to when this
- * package used to be called "lattice"
- */
-
-extern int gridRegisterIndex;
-
-void getDeviceSize(pGEDevDesc dd, double *devWidthCM, double *devHeightCM)
-{
- double left, right, bottom, top;
- dd->dev->size(&left, &right, &bottom, &top, dd->dev);
- *devWidthCM = fabs(right - left) * dd->dev->ipr[0] * 2.54;
- *devHeightCM = fabs(top - bottom) * dd->dev->ipr[1] * 2.54;
-}
-
-static Rboolean deviceChanged(double devWidthCM, double devHeightCM,
- SEXP currentvp)
-{
- Rboolean result = FALSE;
- SEXP pvpDevWidthCM, pvpDevHeightCM;
- PROTECT(pvpDevWidthCM = VECTOR_ELT(currentvp, PVP_DEVWIDTHCM));
- PROTECT(pvpDevHeightCM = VECTOR_ELT(currentvp, PVP_DEVHEIGHTCM));
- if (fabs(REAL(pvpDevWidthCM)[0] - devWidthCM) > 1e-6) {
- result = TRUE;
- REAL(pvpDevWidthCM)[0] = devWidthCM;
- SET_VECTOR_ELT(currentvp, PVP_DEVWIDTHCM, pvpDevWidthCM);
- }
- if (fabs(REAL(pvpDevHeightCM)[0] - devHeightCM) > 1e-6) {
- result = TRUE;
- REAL(pvpDevHeightCM)[0] = devHeightCM;
- SET_VECTOR_ELT(currentvp, PVP_DEVHEIGHTCM, pvpDevHeightCM);
- }
- UNPROTECT(2);
- return result;
-}
-
-/* Register grid with R's graphics engine
- */
-SEXP L_initGrid(SEXP GridEvalEnv)
-{
- R_gridEvalEnv = GridEvalEnv;
- GEregisterSystem(gridCallback, &gridRegisterIndex);
- return R_NilValue;
-}
-
-SEXP L_killGrid()
-{
- GEunregisterSystem(gridRegisterIndex);
- return R_NilValue;
-}
-
-/* Get the current device (the graphics engine creates one if nec.)
- */
-pGEDevDesc getDevice()
-{
- return GEcurrentDevice();
-}
-
-/* If this is the first time that a grid operation has occurred for
- * this device, do some initialisation.
- */
-void dirtyGridDevice(pGEDevDesc dd) {
- if (!LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
- SEXP gsd, griddev;
- /* Record the fact that this device has now received grid output
- */
- gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- PROTECT(griddev = allocVector(LGLSXP, 1));
- LOGICAL(griddev)[0] = TRUE;
- SET_VECTOR_ELT(gsd, GSS_GRIDDEVICE, griddev);
- UNPROTECT(1);
- /*
- * Start the first page on the device
- * (But only if no other graphics system has not already done so)
- */
- if (!GEdeviceDirty(dd)) {
- R_GE_gcontext gc;
- SEXP currentgp = gridStateElement(dd, GSS_GPAR);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- GENewPage(&gc, dd);
- GEdirtyDevice(dd);
- }
- /*
- * Only initialise viewport once new page has started
- * (required for postscript output [at least])
- */
- initVP(dd);
- initDL(dd);
- }
-}
-
-SEXP L_gridDirty()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- dirtyGridDevice(dd);
- return R_NilValue;
-}
-
-void getViewportContext(SEXP vp, LViewportContext *vpc)
-{
- fillViewportContextFromViewport(vp, vpc);
-}
-
-SEXP L_currentViewport()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_VP);
-}
-
-SEXP doSetViewport(SEXP vp,
- /*
- * Are we setting the top-level viewport?
- */
- Rboolean topLevelVP,
- /*
- * Are we pushing a new viewport?
- * (or just revisiting an already-pushed viewport?)
- */
- Rboolean pushing,
- pGEDevDesc dd)
-{
- int i, j;
- double devWidthCM, devHeightCM;
- double xx1, yy1, xx2, yy2;
- SEXP currentClip, widthCM, heightCM;
- /* Get the current device size
- */
- getDeviceSize((dd), &devWidthCM, &devHeightCM);
- if (!topLevelVP && pushing) {
- SEXP parent = gridStateElement(dd, GSS_VP);
- /* Set the viewport's parent
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- SET_VECTOR_ELT(vp, PVP_PARENT, parent);
- /*
- * Make this viewport a child of its parent
- * This involves assigning a value in the parent's
- * children slot (which is an environment), using
- * the viewport's name as the symbol name.
- * NOTE that we are deliberately using defineVar to
- * assign the vp SEXP itself, NOT a copy.
- */
- defineVar(install(CHAR(STRING_ELT(VECTOR_ELT(vp, VP_NAME), 0))),
- vp,
- VECTOR_ELT(parent, PVP_CHILDREN));
- }
- /* Calculate the transformation for the viewport.
- * This will hopefully only involve updating the transformation
- * from the previous viewport.
- * However, if the device has changed size, we will need to
- * recalculate the transformation from the top-level viewport
- * all the way down.
- * NEVER incremental for top-level viewport
- */
- calcViewportTransform(vp, viewportParent(vp),
- !topLevelVP &&
- !deviceChanged(devWidthCM, devHeightCM,
- viewportParent(vp)), dd);
- /*
- * We must "turn off" clipping
- * We set the clip region to be the entire device
- * (actually, as for the top-level viewport, we set it
- * to be slightly larger than the device to avoid
- * "edge effects")
- */
- if (viewportClip(vp) == NA_LOGICAL) {
- xx1 = toDeviceX(-0.5*devWidthCM/2.54, GE_INCHES, dd);
- yy1 = toDeviceY(-0.5*devHeightCM/2.54, GE_INCHES, dd);
- xx2 = toDeviceX(1.5*devWidthCM/2.54, GE_INCHES, dd);
- yy2 = toDeviceY(1.5*devHeightCM/2.54, GE_INCHES, dd);
- GESetClip(xx1, yy1, xx2, yy2, dd);
- }
- /* If we are supposed to clip to this viewport ...
- * NOTE that we will only clip if there is no rotation
- */
- else if (viewportClip(vp)) {
- double rotationAngle = REAL(viewportRotation(vp))[0];
- if (rotationAngle != 0 &&
- rotationAngle != 90 &&
- rotationAngle != 270 &&
- rotationAngle != 360) {
- warning(_("cannot clip to rotated viewport"));
- /* Still need to set clip region for this viewport.
- So "inherit" parent clip region.
- In other words, 'clip=TRUE' + 'rot=15' = 'clip=FALSE'
- */
- SEXP parentClip;
- PROTECT(parentClip = viewportClipRect(viewportParent(vp)));
- xx1 = REAL(parentClip)[0];
- yy1 = REAL(parentClip)[1];
- xx2 = REAL(parentClip)[2];
- yy2 = REAL(parentClip)[3];
- UNPROTECT(1);
- } else {
- /* Calculate a clipping region and set it
- */
- SEXP x1, y1, x2, y2;
- LViewportContext vpc;
- double vpWidthCM = REAL(viewportWidthCM(vp))[0];
- double vpHeightCM = REAL(viewportHeightCM(vp))[0];
- R_GE_gcontext gc;
- LTransform transform;
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- transform[i][j] =
- REAL(viewportTransform(vp))[i + 3*j];
- if (!topLevelVP) {
- PROTECT(x1 = unit(0, L_NPC));
- PROTECT(y1 = unit(0, L_NPC));
- PROTECT(x2 = unit(1, L_NPC));
- PROTECT(y2 = unit(1, L_NPC));
- } else {
- /* Special case for top-level viewport.
- * Set clipping region outside device boundaries.
- * This means that we have set the clipping region to
- * something, but avoids problems if the nominal device
- * limits are actually within its physical limits
- * (e.g., PostScript)
- */
- PROTECT(x1 = unit(-.5, L_NPC));
- PROTECT(y1 = unit(-.5, L_NPC));
- PROTECT(x2 = unit(1.5, L_NPC));
- PROTECT(y2 = unit(1.5, L_NPC));
- }
- getViewportContext(vp, &vpc);
- gcontextFromViewport(vp, &gc, dd);
- transformLocn(x1, y1, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx1, &yy1);
- transformLocn(x2, y2, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx2, &yy2);
- UNPROTECT(4); /* unprotect x1, y1, x2, y2 */
- /* The graphics engine only takes device coordinates
- */
- xx1 = toDeviceX(xx1, GE_INCHES, dd);
- yy1 = toDeviceY(yy1, GE_INCHES, dd);
- xx2 = toDeviceX(xx2, GE_INCHES, dd);
- yy2 = toDeviceY(yy2, GE_INCHES, dd);
- GESetClip(xx1, yy1, xx2, yy2, dd);
- }
- } else {
- /* If we haven't set the clipping region for this viewport
- * we need to save the clipping region from its parent
- * so that when we pop this viewport we can restore that.
- */
- /* NOTE that we are relying on grid.R setting clip=TRUE
- * for the top-level viewport, else *BOOM*!
- */
- SEXP parentClip;
- PROTECT(parentClip = viewportClipRect(viewportParent(vp)));
- xx1 = REAL(parentClip)[0];
- yy1 = REAL(parentClip)[1];
- xx2 = REAL(parentClip)[2];
- yy2 = REAL(parentClip)[3];
- UNPROTECT(1);
- }
- PROTECT(currentClip = allocVector(REALSXP, 4));
- REAL(currentClip)[0] = xx1;
- REAL(currentClip)[1] = yy1;
- REAL(currentClip)[2] = xx2;
- REAL(currentClip)[3] = yy2;
- SET_VECTOR_ELT(vp, PVP_CLIPRECT, currentClip);
- /*
- * Save the current device size
- */
- PROTECT(widthCM = allocVector(REALSXP, 1));
- REAL(widthCM)[0] = devWidthCM;
- SET_VECTOR_ELT(vp, PVP_DEVWIDTHCM, widthCM);
- PROTECT(heightCM = allocVector(REALSXP, 1));
- REAL(heightCM)[0] = devHeightCM;
- SET_VECTOR_ELT(vp, PVP_DEVHEIGHTCM, heightCM);
- UNPROTECT(3);
- return vp;
-}
-
-SEXP L_setviewport(SEXP invp, SEXP hasParent)
-{
- SEXP vp;
- SEXP pushedvp, fcall;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- /*
- * Duplicate the viewport passed in because we are going
- * to modify it to hell and gone.
- */
- PROTECT(vp = duplicate(invp));
- /*
- * Call R function pushedvp()
- */
- PROTECT(fcall = lang2(install("pushedvp"),
- vp));
- PROTECT(pushedvp = eval(fcall, R_gridEvalEnv));
- pushedvp = doSetViewport(pushedvp, !LOGICAL(hasParent)[0], TRUE, dd);
- /* Set the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- setGridStateElement(dd, GSS_VP, pushedvp);
- UNPROTECT(3);
- return R_NilValue;
-}
-
-/*
- * Find a viewport in the current viewport tree by name
- *
- * Have to do this in C code so that we get THE SEXP in
- * the tree, NOT a copy of it.
- */
-
-/*
- * Some helper functions to call R code because I have no idea
- * how to do this in C code
- */
-static Rboolean noChildren(SEXP children)
-{
- SEXP result, fcall;
- PROTECT(fcall = lang2(install("no.children"),
- children));
- PROTECT(result = eval(fcall, R_gridEvalEnv));
- UNPROTECT(2);
- return LOGICAL(result)[0];
-}
-
-static Rboolean childExists(SEXP name, SEXP children)
-{
- SEXP result, fcall;
- PROTECT(fcall = lang3(install("child.exists"),
- name, children));
- PROTECT(result = eval(fcall, R_gridEvalEnv));
- UNPROTECT(2);
- return LOGICAL(result)[0];
-}
-
-static SEXP childList(SEXP children)
-{
- SEXP result, fcall;
- PROTECT(fcall = lang2(install("child.list"),
- children));
- PROTECT(result = eval(fcall, R_gridEvalEnv));
- UNPROTECT(2);
- return result;
-}
-
-/*
-find.in.children <- function(name, children) {
- cpvps <- ls(env=children)
- ncpvp <- length(cpvps)
- count <- 0
- found <- FALSE
- while (count < ncpvp && !found) {
- result <- find.viewport(name, get(cpvps[count+1], env=children))
- found <- result$found
- count <- count + 1
- }
- if (!found)
- result <- list(found=FALSE, pvp=NULL)
- return(result)
-}
-*/
-static SEXP findViewport(SEXP name, SEXP strict, SEXP vp, int depth);
-static SEXP findInChildren(SEXP name, SEXP strict, SEXP children, int depth)
-{
- SEXP childnames = childList(children);
- int n = LENGTH(childnames);
- int count = 0;
- Rboolean found = FALSE;
- SEXP result = R_NilValue;
- PROTECT(childnames);
- PROTECT(result);
- while (count < n && !found) {
- result = findViewport(name, strict,
- findVar(install(CHAR(STRING_ELT(childnames, count))),
- children),
- depth);
- found = INTEGER(VECTOR_ELT(result, 0))[0] > 0;
- count = count + 1;
- }
- if (!found) {
- SEXP temp, zeroDepth;
- PROTECT(temp = allocVector(VECSXP, 2));
- PROTECT(zeroDepth = allocVector(INTSXP, 1));
- INTEGER(zeroDepth)[0] = 0;
- SET_VECTOR_ELT(temp, 0, zeroDepth);
- SET_VECTOR_ELT(temp, 1, R_NilValue);
- UNPROTECT(2);
- result = temp;
- }
- UNPROTECT(2);
- return result;
-}
-
-/*
-find.viewport <- function(name, pvp) {
- found <- FALSE
- if (length(ls(env=pvp$children)) == 0)
- return(list(found=FALSE, pvp=NULL))
- else
- if (exists(name, env=pvp$children, inherits=FALSE))
- return(list(found=TRUE,
- pvp=get(name, env=pvp$children, inherits=FALSE)))
- else
- find.in.children(name, pvp$children)
-}
-*/
-static SEXP findViewport(SEXP name, SEXP strict, SEXP vp, int depth)
-{
- SEXP result, zeroDepth, curDepth;
- PROTECT(result = allocVector(VECSXP, 2));
- PROTECT(zeroDepth = allocVector(INTSXP, 1));
- INTEGER(zeroDepth)[0] = 0;
- PROTECT(curDepth = allocVector(INTSXP, 1));
- INTEGER(curDepth)[0] = depth;
- /*
- * If there are no children, we fail
- */
- if (noChildren(viewportChildren(vp))) {
- SET_VECTOR_ELT(result, 0, zeroDepth);
- SET_VECTOR_ELT(result, 1, R_NilValue);
- } else if (childExists(name, viewportChildren(vp))) {
- SET_VECTOR_ELT(result, 0, curDepth);
- SET_VECTOR_ELT(result, 1,
- /*
- * Does this do inherits=FALSE?
- */
- findVar(install(CHAR(STRING_ELT(name, 0))),
- viewportChildren(vp)));
- } else {
- /*
- * If this is a strict match, fail
- * Otherwise recurse into children
- */
- if (LOGICAL(strict)[0]) {
- SET_VECTOR_ELT(result, 0, zeroDepth);
- SET_VECTOR_ELT(result, 1, R_NilValue);
- } else {
- result = findInChildren(name, strict, viewportChildren(vp),
- depth + 1);
- }
- }
- UNPROTECT(3);
- return result;
-}
-
-SEXP L_downviewport(SEXP name, SEXP strict)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- /* Get the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- SEXP gvp = gridStateElement(dd, GSS_VP);
- /*
- * Try to find the named viewport
- */
- SEXP found, vp;
- int depth = 1;
- PROTECT(found = findViewport(name, strict, gvp, depth));
- if (INTEGER(VECTOR_ELT(found, 0))[0]) {
- vp = doSetViewport(VECTOR_ELT(found, 1), FALSE, FALSE, dd);
- /* Set the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- setGridStateElement(dd, GSS_VP, vp);
- UNPROTECT(1);
- } else {
- /* Important to have an error here, rather than back in
- * R code AFTER this point. Otherwise, an unsuccessful
- * downViewport() will be recorded on the engine DL!
- */
- char msg[1024];
- snprintf(msg, 1024, "Viewport '%s' was not found",
- CHAR(STRING_ELT(name, 0)));
- UNPROTECT(1);
- error(_(msg));
- }
- return VECTOR_ELT(found, 0);
-}
-
-/*
- * Find a viewport PATH in the current viewport tree by name
- *
- * Similar to L_downviewport
- */
-
-static Rboolean pathMatch(SEXP path, SEXP pathsofar, SEXP strict)
-{
- SEXP result, fcall;
- PROTECT(fcall = lang4(install("pathMatch"),
- path, pathsofar, strict));
- PROTECT(result = eval(fcall, R_gridEvalEnv));
- UNPROTECT(2);
- return LOGICAL(result)[0];
-}
-
-static SEXP growPath(SEXP pathsofar, SEXP name)
-{
- SEXP result, fcall;
- if (isNull(pathsofar))
- result = name;
- else {
- PROTECT(fcall = lang3(install("growPath"),
- pathsofar, name));
- PROTECT(result = eval(fcall, R_gridEvalEnv));
- UNPROTECT(2);
- }
- return result;
-}
-
-static SEXP findvppath(SEXP path, SEXP name, SEXP strict,
- SEXP pathsofar, SEXP vp, int depth);
-static SEXP findvppathInChildren(SEXP path, SEXP name,
- SEXP strict, SEXP pathsofar,
- SEXP children, int depth)
-{
- SEXP childnames = childList(children);
- int n = LENGTH(childnames);
- int count = 0;
- Rboolean found = FALSE;
- SEXP result = R_NilValue;
- PROTECT(childnames);
- PROTECT(result);
- while (count < n && !found) {
- SEXP vp, newpathsofar;
- PROTECT(vp = findVar(install(CHAR(STRING_ELT(childnames, count))),
- children));
- PROTECT(newpathsofar = growPath(pathsofar,
- VECTOR_ELT(vp, VP_NAME)));
- result = findvppath(path, name, strict, newpathsofar, vp, depth);
- found = INTEGER(VECTOR_ELT(result, 0))[0] > 0;
- count = count + 1;
- UNPROTECT(2);
- }
- if (!found) {
- SEXP temp, zeroDepth;
- PROTECT(temp = allocVector(VECSXP, 2));
- PROTECT(zeroDepth = allocVector(INTSXP, 1));
- INTEGER(zeroDepth)[0] = 0;
- SET_VECTOR_ELT(temp, 0, zeroDepth);
- SET_VECTOR_ELT(temp, 1, R_NilValue);
- UNPROTECT(2);
- result = temp;
- }
- UNPROTECT(2);
- return result;
-}
-
-static SEXP findvppath(SEXP path, SEXP name, SEXP strict,
- SEXP pathsofar, SEXP vp, int depth)
-{
- SEXP result, zeroDepth, curDepth;
- PROTECT(result = allocVector(VECSXP, 2));
- PROTECT(zeroDepth = allocVector(INTSXP, 1));
- INTEGER(zeroDepth)[0] = 0;
- PROTECT(curDepth = allocVector(INTSXP, 1));
- INTEGER(curDepth)[0] = depth;
- /*
- * If there are no children, we fail
- */
- if (noChildren(viewportChildren(vp))) {
- SET_VECTOR_ELT(result, 0, zeroDepth);
- SET_VECTOR_ELT(result, 1, R_NilValue);
-
- }
- /*
- * Check for the viewport name AND whether the rest
- * of the path matches (possibly strictly)
- */
- else if (childExists(name, viewportChildren(vp)) &&
- pathMatch(path, pathsofar, strict)) {
- SET_VECTOR_ELT(result, 0, curDepth);
- SET_VECTOR_ELT(result, 1,
- /*
- * Does this do inherits=FALSE?
- */
- findVar(install(CHAR(STRING_ELT(name, 0))),
- viewportChildren(vp)));
- } else {
- result = findvppathInChildren(path, name, strict, pathsofar,
- viewportChildren(vp), depth + 1);
- }
- UNPROTECT(3);
- return result;
-}
-
-SEXP L_downvppath(SEXP path, SEXP name, SEXP strict)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- /* Get the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- SEXP gvp = gridStateElement(dd, GSS_VP);
- /*
- * Try to find the named viewport
- */
- SEXP found, vp;
- int depth = 1;
- PROTECT(found = findvppath(path, name, strict, R_NilValue, gvp, depth));
- if (INTEGER(VECTOR_ELT(found, 0))[0]) {
- vp = doSetViewport(VECTOR_ELT(found, 1), FALSE, FALSE, dd);
- /* Set the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- setGridStateElement(dd, GSS_VP, vp);
- UNPROTECT(1);
- } else {
- /* Important to have an error here, rather than back in
- * R code AFTER this point. Otherwise, an unsuccessful
- * downViewport() will be recorded on the engine DL!
- */
- char msg[1024];
- snprintf(msg, 1024, "Viewport '%s' was not found",
- CHAR(STRING_ELT(name, 0)));
- UNPROTECT(1);
- error(_(msg));
- }
- return VECTOR_ELT(found, 0);
-}
-
-/* This is similar to L_setviewport, except that it will NOT
- * recalculate the viewport transform if the device has not changed size
- */
-SEXP L_unsetviewport(SEXP n)
-{
- int i;
- double xx1, yy1, xx2, yy2;
- double devWidthCM, devHeightCM;
- SEXP parentClip;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- /* Get the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- SEXP gvp = gridStateElement(dd, GSS_VP);
- /* NOTE that the R code has already checked that .grid.viewport$parent
- * is non-NULL
- *
- * BUT this may not be called from R code !!
- * (e.g., when the graphics engine display list is replayed;
- * problems can occur when grid output is mixed with base output;
- * for example, plot.new() is called between a viewport push and pop)
- */
- SEXP newvp = VECTOR_ELT(gvp, PVP_PARENT);
- if (isNull(newvp))
- error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
- for (i = 1; i < INTEGER(n)[0]; i++) {
- gvp = newvp;
- newvp = VECTOR_ELT(gvp, PVP_PARENT);
- if (isNull(newvp))
- error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
- }
- /*
- * Remove the child (gvp) from the parent's (newvp) "list" of
- * children
- */
- /*
- * This has to be done via a call to R-level ...
- * remove(gvp$name, envir=newvp$children, inherits=FALSE)
- * ... because RemoveVariable in envir.c is not exported (why not?)
- *
- * I tried to model this on the example in the section
- * "System and foreign language interfaces ... Evaluating R expressions"
- * in the "Writing R Extensions" manual, but the compiler didn't
- * like CAR(t) as an lvalue.
- */
- {
- SEXP fcall, false, t;
- PROTECT(gvp); PROTECT(newvp);
- PROTECT(false = allocVector(LGLSXP, 1));
- LOGICAL(false)[0] = FALSE;
- PROTECT(fcall = lang4(install("remove"),
- VECTOR_ELT(gvp, VP_NAME),
- VECTOR_ELT(newvp, PVP_CHILDREN),
- false));
- t = fcall;
- t = CDR(CDR(t));
- SET_TAG(t, install("envir"));
- t = CDR(t);
- SET_TAG(t, install("inherits"));
- eval(fcall, R_gridEvalEnv);
- UNPROTECT(4);
- }
- /* Get the current device size
- */
- getDeviceSize(dd, &devWidthCM, &devHeightCM);
- if (deviceChanged(devWidthCM, devHeightCM, newvp))
- calcViewportTransform(newvp, viewportParent(newvp), 1, dd);
- /*
- * Enforce the current viewport settings
- */
- setGridStateElement(dd, GSS_GPAR, viewportgpar(newvp));
- /* Set the clipping region to the parent's cur.clip
- */
- parentClip = viewportClipRect(newvp);
- xx1 = REAL(parentClip)[0];
- yy1 = REAL(parentClip)[1];
- xx2 = REAL(parentClip)[2];
- yy2 = REAL(parentClip)[3];
- GESetClip(xx1, yy1, xx2, yy2, dd);
- /* Set the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- setGridStateElement(dd, GSS_VP, newvp);
- /*
- * Remove the parent from the child
- * This is not strictly necessary, but it is conceptually
- * more complete and makes it more likely that we will
- * detect incorrect code elsewhere (because it is likely to
- * trigger a segfault if other code is incorrect)
- *
- * NOTE: Do NOT do this any earlier or you will
- * remove the PROTECTive benefit of newvp pointing
- * to part of the (global) grid state
- */
- SET_VECTOR_ELT(gvp, PVP_PARENT, R_NilValue);
- return R_NilValue;
-}
-
-/* This is similar to L_unsetviewport, except that it will NOT
- * modify parent-child relations
- */
-SEXP L_upviewport(SEXP n)
-{
- int i;
- double xx1, yy1, xx2, yy2;
- double devWidthCM, devHeightCM;
- SEXP parentClip;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- /* Get the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- SEXP gvp = gridStateElement(dd, GSS_VP);
- SEXP newvp = VECTOR_ELT(gvp, PVP_PARENT);
- if (isNull(newvp))
- error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
- for (i = 1; i < INTEGER(n)[0]; i++) {
- gvp = newvp;
- newvp = VECTOR_ELT(gvp, PVP_PARENT);
- if (isNull(newvp))
- error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
- }
- /* Get the current device size
- */
- getDeviceSize(dd, &devWidthCM, &devHeightCM);
- if (deviceChanged(devWidthCM, devHeightCM, newvp))
- calcViewportTransform(newvp, viewportParent(newvp), 1, dd);
- /*
- * Enforce the current viewport settings
- */
- setGridStateElement(dd, GSS_GPAR, viewportgpar(newvp));
- /* Set the clipping region to the parent's cur.clip
- */
- parentClip = viewportClipRect(newvp);
- xx1 = REAL(parentClip)[0];
- yy1 = REAL(parentClip)[1];
- xx2 = REAL(parentClip)[2];
- yy2 = REAL(parentClip)[3];
- GESetClip(xx1, yy1, xx2, yy2, dd);
-#if 0
- /* This is a VERY short term fix to avoid mucking
- * with the core graphics during feature freeze
- * It should be removed post R 1.4 release
- */
- dd->dev->clipLeft = fmin2(xx1, xx2);
- dd->dev->clipRight = fmax2(xx1, xx2);
- dd->dev->clipTop = fmax2(yy1, yy2);
- dd->dev->clipBottom = fmin2(yy1, yy2);
-#endif
- /* Set the value of the current viewport for the current device
- * Need to do this in here so that redrawing via R BASE display
- * list works
- */
- setGridStateElement(dd, GSS_VP, newvp);
- return R_NilValue;
-}
-
-SEXP L_getDisplayList()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_DL);
-}
-
-SEXP L_setDisplayList(SEXP dl)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_DL, dl);
- return R_NilValue;
-}
-
-/*
- * Get the element at index on the DL
- */
-SEXP L_getDLelt(SEXP index)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- SEXP dl, result;
- PROTECT(dl = gridStateElement(dd, GSS_DL));
- result = VECTOR_ELT(dl, INTEGER(index)[0]);
- UNPROTECT(1);
- return result;
-}
-
-/* Add an element to the display list at the current location
- * Location is maintained in R code
- */
-SEXP L_setDLelt(SEXP value)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- SEXP dl;
- PROTECT(dl = gridStateElement(dd, GSS_DL));
- SET_VECTOR_ELT(dl, INTEGER(gridStateElement(dd, GSS_DLINDEX))[0], value);
- UNPROTECT(1);
- return R_NilValue;
-}
-
-SEXP L_getDLindex()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_DLINDEX);
-}
-
-SEXP L_setDLindex(SEXP index)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_DLINDEX, index);
- return R_NilValue;
-}
-
-SEXP L_getDLon()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_DLON);
-}
-
-SEXP L_setDLon(SEXP value)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- SEXP prev;
- prev = gridStateElement(dd, GSS_DLON);
- setGridStateElement(dd, GSS_DLON, value);
- return prev;
-}
-
-SEXP L_getEngineDLon()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_ENGINEDLON);
-}
-
-SEXP L_setEngineDLon(SEXP value)
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_ENGINEDLON, value);
- return R_NilValue;
-}
-
-SEXP L_getCurrentGrob()
-{
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_CURRGROB);
-}
-
-SEXP L_setCurrentGrob(SEXP value)
-{
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_CURRGROB, value);
- return R_NilValue;
-}
-
-SEXP L_getEngineRecording()
-{
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_ENGINERECORDING);
-}
-
-SEXP L_setEngineRecording(SEXP value)
-{
- pGEDevDesc dd = getDevice();
- setGridStateElement(dd, GSS_ENGINERECORDING, value);
- return R_NilValue;
-}
-
-SEXP L_currentGPar()
-{
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- return gridStateElement(dd, GSS_GPAR);
-}
-
-SEXP L_newpagerecording()
-{
- pGEDevDesc dd = getDevice();
- if (dd->ask) {
- NewFrameConfirm(dd->dev);
- /*
- * User may have killed device during pause for prompt
- */
- if (NoDevices())
- error(_("attempt to plot on null device"));
- else
- /*
- * Should throw an error if dd != GECurrentDevice ?
- */
- dd = GEcurrentDevice();
- }
- GEinitDisplayList(dd);
- return R_NilValue;
-}
-
-SEXP L_newpage()
-{
- pGEDevDesc dd = getDevice();
- R_GE_gcontext gc;
- /*
- * Has the device been drawn on yet?
- */
- Rboolean deviceDirty = GEdeviceDirty(dd);
- /*
- * Has the device been drawn on BY GRID yet?
- */
- Rboolean deviceGridDirty = LOGICAL(gridStateElement(dd,
- GSS_GRIDDEVICE))[0];
- /*
- * Initialise grid on device
- * If no drawing on device yet, does a new page
- */
- if (!deviceGridDirty) {
- dirtyGridDevice(dd);
- }
- /*
- * If device has previously been drawn on (by grid or other system)
- * do a new page
- */
- if (deviceGridDirty || deviceDirty) {
- SEXP currentgp = gridStateElement(dd, GSS_GPAR);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- GENewPage(&gc, dd);
- }
- return R_NilValue;
-}
-
-SEXP L_initGPar()
-{
- pGEDevDesc dd = getDevice();
- initGPar(dd);
- return R_NilValue;
-}
-
-SEXP L_initViewportStack()
-{
- pGEDevDesc dd = getDevice();
- initVP(dd);
- return R_NilValue;
-}
-
-SEXP L_initDisplayList()
-{
- pGEDevDesc dd = getDevice();
- initDL(dd);
- return R_NilValue;
-}
-
-void getViewportTransform(SEXP currentvp,
- pGEDevDesc dd,
- double *vpWidthCM, double *vpHeightCM,
- LTransform transform, double *rotationAngle)
-{
- int i, j;
- double devWidthCM, devHeightCM;
- getDeviceSize((dd), &devWidthCM, &devHeightCM) ;
- if (deviceChanged(devWidthCM, devHeightCM, currentvp)) {
- /* IF the device has changed, recalculate the viewport transform
- */
- calcViewportTransform(currentvp, viewportParent(currentvp), 1, dd);
- }
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- transform[i][j] =
- REAL(viewportTransform(currentvp))[i + 3*j];
- *rotationAngle = REAL(viewportRotation(currentvp))[0];
- *vpWidthCM = REAL(viewportWidthCM(currentvp))[0];
- *vpHeightCM = REAL(viewportHeightCM(currentvp))[0];
-}
-
-
-/***************************
- * CONVERSION FUNCTIONS
- ***************************
- */
-
-/*
- * WITHIN THE CURRENT VIEWPORT ...
- *
- * Given a unit object and whether it is a location/dimension,
- * convert to location/dimension in unit B
- *
- * NOTE: When this is used to convert a mouse click on a device to
- * a location/dimension, the conversion of the mouse click to
- * a unit within the current viewport has to be done elsewhere.
- * e.g., in interactive.R, this is done by applying the inverse
- * of the current viewport transformation to get a location in
- * inches within the current viewport.
- *
- * This should ideally create a unit object to ensure that the
- * values it returns are treated as values in the correct
- * coordinate system. For now, this is MUCH easier to do in
- * R code, so it is the responsibility of the R code calling this
- * to create the unit object correctly/honestly.
- *
- * NOTE also that the unitto supplied should be a "valid" integer
- * (the best way to get that is to use the valid.units()
- * function in unit.R)
- *
- * what = 0 means x, 1 means y, 2 means width, 3 means height
- */
-SEXP L_convert(SEXP x, SEXP whatfrom,
- SEXP whatto, SEXP unitto) {
- int i, nx;
- SEXP answer;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- int TOunit, FROMaxis, TOaxis;
- Rboolean relConvert;
- /*
- * Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- /*
- * We do not need the current transformation, but
- * we need the side effects of calculating it in
- * case the device has been resized (or only just created)
- */
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- nx = unitLength(x);
- PROTECT(answer = allocVector(REALSXP, nx));
- for (i=0; i<nx; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- TOunit = INTEGER(unitto)[i % LENGTH(unitto)];
- FROMaxis = INTEGER(whatfrom)[0];
- TOaxis = INTEGER(whatto)[0];
- /*
- * Special case: FROM unit is just a plain, relative unit AND
- * TO unit is relative AND
- * NOT converting from 'x' to 'y' (or vice versa) ...
- *
- * ... AND relevant widthCM or heightCM is zero
- *
- * In these cases do NOT transform thru INCHES
- * (to avoid divide-by-zero, but still do something useful)
- */
- relConvert = (!isUnitArithmetic(x) && !isUnitList(x) &&
- (unitUnit(x, i) == L_NATIVE || unitUnit(x, i) == L_NPC) &&
- (TOunit == L_NATIVE || TOunit == L_NPC) &&
- ((FROMaxis == TOaxis) ||
- (FROMaxis == 0 && TOaxis == 2) ||
- (FROMaxis == 2 && TOaxis == 0) ||
- (FROMaxis == 1 && TOaxis == 3) ||
- (FROMaxis == 3 && TOaxis == 1)));
- /*
- * First, convert the unit object passed in to a value in INCHES
- * (within the current viewport)
- */
- switch (FROMaxis) {
- case 0:
- if (relConvert && vpWidthCM < 1e-6) {
- REAL(answer)[i] =
- transformXYtoNPC(unitValue(x, i), unitUnit(x, i),
- vpc.xscalemin, vpc.xscalemax);
- } else {
- relConvert = FALSE;
- REAL(answer)[i] =
- transformXtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 1:
- if (relConvert && vpHeightCM < 1e-6) {
- REAL(answer)[i] =
- transformXYtoNPC(unitValue(x, i), unitUnit(x, i),
- vpc.yscalemin, vpc.yscalemax);
- } else {
- relConvert = FALSE;
- REAL(answer)[i] =
- transformYtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 2:
- if (relConvert && vpWidthCM < 1e-6) {
- REAL(answer)[i] =
- transformWHtoNPC(unitValue(x, i), unitUnit(x, i),
- vpc.xscalemin, vpc.xscalemax);
- } else {
- relConvert = FALSE;
- REAL(answer)[i] =
- transformWidthtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 3:
- if (relConvert && vpHeightCM < 1e-6) {
- REAL(answer)[i] =
- transformWHtoNPC(unitValue(x, i), unitUnit(x, i),
- vpc.yscalemin, vpc.yscalemax);
- } else {
- relConvert = FALSE;
- REAL(answer)[i] =
- transformHeighttoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- }
- /*
- * Now, convert the values in INCHES to a value in the specified
- * coordinate system
- * (within the current viewport)
- *
- * BUT do NOT do this step for the special "relConvert" case
- */
- switch (TOaxis) {
- case 0:
- if (relConvert) {
- REAL(answer)[i] = transformXYfromNPC(REAL(answer)[i], TOunit,
- vpc.xscalemin,
- vpc.xscalemax);
- } else {
- REAL(answer)[i] =
- transformXYFromINCHES(REAL(answer)[i], TOunit,
- vpc.xscalemin,
- vpc.xscalemax,
- &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 1:
- if (relConvert) {
- REAL(answer)[i] = transformXYfromNPC(REAL(answer)[i], TOunit,
- vpc.yscalemin,
- vpc.yscalemax);
- } else {
- REAL(answer)[i] =
- transformXYFromINCHES(REAL(answer)[i], TOunit,
- vpc.yscalemin,
- vpc.yscalemax,
- &gc,
- vpHeightCM, vpWidthCM,
- dd);
- }
- break;
- case 2:
- if (relConvert) {
- REAL(answer)[i] = transformWHfromNPC(REAL(answer)[i], TOunit,
- vpc.xscalemin,
- vpc.xscalemax);
- } else {
- REAL(answer)[i] =
- transformWidthHeightFromINCHES(REAL(answer)[i], TOunit,
- vpc.xscalemin,
- vpc.xscalemax,
- &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 3:
- if (relConvert) {
- REAL(answer)[i] = transformWHfromNPC(REAL(answer)[i], TOunit,
- vpc.yscalemin,
- vpc.yscalemax);
- } else {
- REAL(answer)[i] =
- transformWidthHeightFromINCHES(REAL(answer)[i], TOunit,
- vpc.yscalemin,
- vpc.yscalemax,
- &gc,
- vpHeightCM, vpWidthCM,
- dd);
- break;
- }
- }
- }
- UNPROTECT(1);
- return answer;
-}
-
-/*
- * Given a layout.pos.row and a layout.pos.col, calculate
- * the region allocated by the layout of the current viewport
- *
- * Not a conversion as such, but similarly vulnerable to device resizing
- */
-SEXP L_layoutRegion(SEXP layoutPosRow, SEXP layoutPosCol) {
- LViewportLocation vpl;
- SEXP answer;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LTransform transform;
- SEXP currentvp;
- /*
- * Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- //currentgp = gridStateElement(dd, GSS_GPAR);
- /*
- * We do not need the current transformation, but
- * we need the side effects of calculating it in
- * case the device has been resized (or only just created)
- */
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- /*
- * Only proceed if there is a layout currently defined
- */
- if (isNull(viewportLayout(currentvp)))
- error(_("there is no layout defined"));
- /*
- * The result is a numeric containing left, bottom, width, and height
- */
- PROTECT(answer = allocVector(REALSXP, 4));
- /*
- * NOTE: We are assuming here that calcViewportLocationFromLayout
- * returns the allocated region with a ("left", "bottom")
- * justification. This is CURRENTLY true, but ...
- */
- calcViewportLocationFromLayout(layoutPosRow,
- layoutPosCol,
- currentvp,
- &vpl);
- /*
- * I am not returning the units created in C code
- * because they do not have the units attribute set
- * so they do not behave nicely back in R code.
- * Instead, I take the values and my knowledge that they
- * are NPC units and construct real unit objects back in
- * R code.
- */
- REAL(answer)[0] = unitValue(vpl.x, 0);
- REAL(answer)[1] = unitValue(vpl.y, 0);
- REAL(answer)[2] = unitValue(vpl.width, 0);
- REAL(answer)[3] = unitValue(vpl.height, 0);
- UNPROTECT(1);
- return answer;
-}
-
-/***************************
- * EDGE DETECTION
- ***************************
- */
-
-/*
- * Calculate the point on the edge of a rectangle at angle theta
- * 0 = East, 180 = West, etc ...
- * Assumes that x- and y-values are in INCHES
- * Assumes that theta is within [0, 360)
- */
-static void rectEdge(double xmin, double ymin, double xmax, double ymax,
- double theta,
- double *edgex, double *edgey)
-{
- double xm = (xmin + xmax)/2;
- double ym = (ymin + ymax)/2;
- double dx = (xmax - xmin)/2;
- double dy = (ymax - ymin)/2;
- /*
- * FIXME: Special case 0 width or 0 height
- */
- /*
- * Special case angles
- */
- if (theta == 0) {
- *edgex = xmax;
- *edgey = ym;
- } else if (theta == 270) {
- *edgex = xm;
- *edgey = ymin;
- } else if (theta == 180) {
- *edgex = xmin;
- *edgey = ym;
- } else if (theta == 90) {
- *edgex = xm;
- *edgey = ymax;
- } else {
- double cutoff = dy/dx;
- double angle = theta/180*M_PI;
- double tanTheta = tan(angle);
- double cosTheta = cos(angle);
- double sinTheta = sin(angle);
- if (fabs(tanTheta) < cutoff) { /* Intersect with side */
- if (cosTheta > 0) { /* Right side */
- *edgex = xmax;
- *edgey = ym + tanTheta*dx;
- } else { /* Left side */
- *edgex = xmin;
- *edgey = ym - tanTheta*dx;
- }
- } else { /* Intersect with top/bottom */
- if (sinTheta > 0) { /* Top */
- *edgey = ymax;
- *edgex = xm + dy/tanTheta;
- } else { /* Bottom */
- *edgey = ymin;
- *edgex = xm - dy/tanTheta;
- }
- }
- }
-}
-
-/*
- * Calculate the point on the edge of a rectangle at angle theta
- * 0 = East, 180 = West, etc ...
- * Assumes that x- and y-values are in INCHES
- * Assumes that theta is within [0, 360)
- */
-static void circleEdge(double x, double y, double r,
- double theta,
- double *edgex, double *edgey)
-{
- double angle = theta/180*M_PI;
- *edgex = x + r*cos(angle);
- *edgey = y + r*sin(angle);
-}
-
-/*
- * Calculate the point on the edge of a *convex* polygon at angle theta
- * 0 = East, 180 = West, etc ...
- * Assumes that x- and y-values are in INCHES
- * Assumes that vertices are in clock-wise order
- * Assumes that theta is within [0, 360)
- */
-static void polygonEdge(double *x, double *y, int n,
- double theta,
- double *edgex, double *edgey) {
- int i, v1, v2;
- double xm, ym;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- int found = 0;
- double angle = theta/180*M_PI;
- double vangle1, vangle2;
- /*
- * Find "centre" of polygon
- */
- for (i=0; i<n; i++) {
- if (x[i] < xmin)
- xmin = x[i];
- if (x[i] > xmax)
- xmax = x[i];
- if (y[i] < ymin)
- ymin = y[i];
- if (y[i] > ymax)
- ymax = y[i];
- }
- xm = (xmin + xmax)/2;
- ym = (ymin + ymax)/2;
- /*
- * Special case zero-width or zero-height
- */
- if (fabs(xmin - xmax) < 1e-6) {
- *edgex = xmin;
- if (theta == 90)
- *edgey = ymax;
- else if (theta == 270)
- *edgey = ymin;
- else
- *edgey = ym;
- return;
- }
- if (fabs(ymin - ymax) < 1e-6) {
- *edgey = ymin;
- if (theta == 0)
- *edgex = xmax;
- else if (theta == 180)
- *edgex = xmin;
- else
- *edgex = xm;
- return;
- }
- /*
- * Find edge that intersects line from centre at angle theta
- */
- for (i=0; i<n; i++) {
- v1 = i;
- v2 = v1 + 1;
- if (v2 == n)
- v2 = 0;
- /*
- * Result of atan2 is in range -PI, PI so convert to
- * 0, 360 to correspond to angle
- */
- vangle1 = atan2(y[v1] - ym, x[v1] - xm);
- if (vangle1 < 0)
- vangle1 = vangle1 + 2*M_PI;
- vangle2 = atan2(y[v2] - ym, x[v2] - xm);
- if (vangle2 < 0)
- vangle2 = vangle2 + 2*M_PI;
- /*
- * If vangle1 < vangle2 then angles are either side of 0
- * so check is more complicated
- */
- if ((vangle1 >= vangle2 &&
- vangle1 >= angle && vangle2 < angle) ||
- (vangle1 < vangle2 &&
- ((vangle1 >= angle && 0 <= angle) ||
- (vangle2 < angle && 2*M_PI >= angle)))) {
- found = 1;
- break;
- }
- }
- /*
- * Find intersection point of "line from centre to bounding rect"
- * and edge
- */
- if (found) {
- double x1 = xm;
- double y1 = ym;
- double x2, y2;
- double x3 = x[v1];
- double y3 = y[v1];
- double x4 = x[v2];
- double y4 = y[v2];
- double numa, denom, ua;
- rectEdge(xmin, ymin, xmax, ymax, theta,
- &x2, &y2);
- numa = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
- denom = ((y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1));
- ua = numa/denom;
- if (!R_FINITE(ua)) {
- /*
- * Should only happen if lines are parallel, which
- * shouldn't happen! Unless, perhaps the polygon has
- * zero extent vertically or horizontally ... ?
- */
- error(_("polygon edge not found (zero-width or zero-height?)"));
- }
- /*
- * numb = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
- * ub = numb/denom;
- */
- *edgex = x1 + ua*(x2 - x1);
- *edgey = y1 + ua*(y2 - y1);
- } else {
- error(_("polygon edge not found"));
- }
-}
-
-/*
- * Given a set of points, calculate the convex hull then
- * find the edge of that hull
- *
- * NOTE: assumes that 'grDevices' package has been loaded
- * so that chull() is available (grid depends on grDevices)
- */
-static void hullEdge(double *x, double *y, int n,
- double theta,
- double *edgex, double *edgey)
-{
- const void *vmax;
- int i, nh;
- double *hx, *hy;
- SEXP xin, yin, chullFn, R_fcall, hull;
- int adjust = 0;
- double *xkeep, *ykeep;
- vmax = vmaxget();
- /* Remove any NA's because chull() can't cope with them */
- xkeep = (double *) R_alloc(n, sizeof(double));
- ykeep = (double *) R_alloc(n, sizeof(double));
- for (i=0; i<n; i++) {
- if (!R_FINITE(x[i]) || !R_FINITE(y[i])) {
- adjust--;
- } else {
- xkeep[i + adjust] = x[i];
- ykeep[i + adjust] = y[i];
- }
- }
- n = n + adjust;
- PROTECT(xin = allocVector(REALSXP, n));
- PROTECT(yin = allocVector(REALSXP, n));
- for (i=0; i<n; i++) {
- REAL(xin)[i] = xkeep[i];
- REAL(yin)[i] = ykeep[i];
- }
- /*
- * Determine convex hull
- */
- PROTECT(chullFn = findFun(install("chull"), R_gridEvalEnv));
- PROTECT(R_fcall = lang3(chullFn, xin, yin));
- PROTECT(hull = eval(R_fcall, R_gridEvalEnv));
- nh = LENGTH(hull);
- hx = (double *) R_alloc(nh, sizeof(double));
- hy = (double *) R_alloc(nh, sizeof(double));
- for (i=0; i<nh; i++) {
- hx[i] = x[INTEGER(hull)[i] - 1];
- hy[i] = y[INTEGER(hull)[i] - 1];
- }
- /*
- * Find edge of that hull
- */
- polygonEdge(hx, hy, nh, theta,
- edgex, edgey);
- vmaxset(vmax);
- UNPROTECT(5);
-}
-
-/***************************
- * DRAWING PRIMITIVES
- ***************************
- */
-
-/*
- * Draw an arrow head, given the vertices of the arrow head.
- * Assume vertices are in DEVICE coordinates.
- */
-static void drawArrow(double *x, double *y, SEXP type, int i,
- const pGEcontext gc, pGEDevDesc dd)
-{
- int nt = LENGTH(type);
- switch (INTEGER(type)[i % nt]) {
- case 1:
- GEPolyline(3, x, y, gc, dd);
- break;
- case 2:
- GEPolygon(3, x, y, gc, dd);
- break;
- }
-}
-
-/*
- * Calculate vertices for drawing an arrow head.
- * Assumes that x and y locations are in INCHES.
- * Returns vertices in DEVICE coordinates.
- */
-static void calcArrow(double x1, double y1,
- double x2, double y2,
- SEXP angle, SEXP length, int i,
- LViewportContext vpc,
- double vpWidthCM, double vpHeightCM,
- double *vertx, double *verty,
- const pGEcontext gc, pGEDevDesc dd)
-{
- int na = LENGTH(angle);
- int nl = LENGTH(length);
- double xc, yc, rot;
- double l1, l2, l, a;
- l1 = transformWidthtoINCHES(length, i % nl, vpc, gc,
- vpWidthCM, vpHeightCM,
- dd);
- l2 = transformHeighttoINCHES(length, i % nl, vpc, gc,
- vpWidthCM, vpHeightCM,
- dd);
- l = fmin2(l1, l2);
- a = DEG2RAD * REAL(angle)[i % na];
- xc = x2 - x1;
- yc = y2 - y1;
- rot= atan2(yc, xc);
- vertx[0] = toDeviceX(x1 + l * cos(rot+a),
- GE_INCHES, dd);
- verty[0] = toDeviceY(y1 + l * sin(rot+a),
- GE_INCHES, dd);
- vertx[1] = toDeviceX(x1,
- GE_INCHES, dd);
- verty[1] = toDeviceY(y1,
- GE_INCHES, dd);
- vertx[2] = toDeviceX(x1 + l * cos(rot-a),
- GE_INCHES, dd);
- verty[2] = toDeviceY(y1 + l * sin(rot-a),
- GE_INCHES, dd);
-}
-
-/*
- * Assumes x and y are at least length 2
- * Also assumes x and y are in DEVICE coordinates
- */
-static void arrows(double *x, double *y, int n,
- SEXP arrow, int i,
- /*
- * Which ends we are allowed to draw arrow heads on
- * (we may be drawing a line segment that has been
- * broken by NAs)
- */
- Rboolean start, Rboolean end,
- LViewportContext vpc,
- double vpWidthCM, double vpHeightCM,
- const pGEcontext gc, pGEDevDesc dd)
-{
- /*
- * Write a checkArrow() function to make
- * sure 'a' is a valid arrow description ?
- * If someone manages to sneak in a
- * corrupt arrow description ... BOOM!
- */
- SEXP ends = VECTOR_ELT(arrow, GRID_ARROWENDS);
- int ne = LENGTH(ends);
- double vertx[3], verty[3];
- Rboolean first, last;
- if (n < 2)
- error(_("require at least two points to draw arrow"));
- first = TRUE;
- last = TRUE;
- switch (INTEGER(ends)[i % ne]) {
- case 2:
- first = FALSE;
- break;
- case 1:
- last = FALSE;
- break;
- }
- if (first && start) {
- calcArrow(fromDeviceX(x[0], GE_INCHES, dd),
- fromDeviceY(y[0], GE_INCHES, dd),
- fromDeviceX(x[1], GE_INCHES, dd),
- fromDeviceY(y[1], GE_INCHES, dd),
- VECTOR_ELT(arrow, GRID_ARROWANGLE),
- VECTOR_ELT(arrow, GRID_ARROWLENGTH),
- i, vpc, vpWidthCM, vpHeightCM, vertx, verty, gc, dd);
- drawArrow(vertx, verty,
- VECTOR_ELT(arrow, GRID_ARROWTYPE), i,
- gc, dd);
- }
- if (last && end) {
- calcArrow(fromDeviceX(x[n - 1], GE_INCHES, dd),
- fromDeviceY(y[n - 1], GE_INCHES, dd),
- fromDeviceX(x[n - 2], GE_INCHES, dd),
- fromDeviceY(y[n - 2], GE_INCHES, dd),
- VECTOR_ELT(arrow, GRID_ARROWANGLE),
- VECTOR_ELT(arrow, GRID_ARROWLENGTH),
- i, vpc, vpWidthCM, vpHeightCM, vertx, verty, gc, dd);
- drawArrow(vertx, verty,
- VECTOR_ELT(arrow, GRID_ARROWTYPE), i,
- gc, dd);
- }
-}
-
-SEXP L_moveTo(SEXP x, SEXP y)
-{
- double xx, yy;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP devloc, prevloc;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- PROTECT(prevloc = gridStateElement(dd, GSS_PREVLOC));
- PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- /* Convert the x and y values to CM locations */
- transformLocn(x, y, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- /*
- * Non-finite values are ok here
- * L_lineTo figures out what to draw
- * when values are non-finite
- */
- REAL(prevloc)[0] = REAL(devloc)[0];
- REAL(prevloc)[1] = REAL(devloc)[1];
- REAL(devloc)[0] = xx;
- REAL(devloc)[1] = yy;
- UNPROTECT(2);
- return R_NilValue;
-}
-
-SEXP L_lineTo(SEXP x, SEXP y, SEXP arrow)
-{
- double xx0, yy0, xx1, yy1;
- double xx, yy;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP devloc, prevloc;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- PROTECT(prevloc = gridStateElement(dd, GSS_PREVLOC));
- PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- /* Convert the x and y values to CM locations */
- transformLocn(x, y, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- REAL(prevloc)[0] = REAL(devloc)[0];
- REAL(prevloc)[1] = REAL(devloc)[1];
- REAL(devloc)[0] = xx;
- REAL(devloc)[1] = yy;
- /* The graphics engine only takes device coordinates
- */
- xx0 = toDeviceX(REAL(prevloc)[0], GE_INCHES, dd);
- yy0 = toDeviceY(REAL(prevloc)[1], GE_INCHES, dd),
- xx1 = toDeviceX(xx, GE_INCHES, dd);
- yy1 = toDeviceY(yy, GE_INCHES, dd);
- if (R_FINITE(xx0) && R_FINITE(yy0) &&
- R_FINITE(xx1) && R_FINITE(yy1)) {
- GEMode(1, dd);
- GELine(xx0, yy0, xx1, yy1, &gc, dd);
- if (!isNull(arrow)) {
- double ax[2], ay[2];
- ax[0] = xx0;
- ax[1] = xx1;
- ay[0] = yy0;
- ay[1] = yy1;
- arrows(ax, ay, 2,
- arrow, 0, TRUE, TRUE,
- vpc, vpWidthCM, vpHeightCM, &gc, dd);
- }
- GEMode(0, dd);
- }
- UNPROTECT(2);
- return R_NilValue;
-}
-
-/* We are assuming here that the R code has checked that x and y
- * are unit objects and that vp is a viewport
- */
-SEXP L_lines(SEXP x, SEXP y, SEXP index, SEXP arrow)
-{
- int i, j, nx, nl, start=0;
- double *xx, *yy;
- double xold, yold;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- const void *vmax;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- GEMode(1, dd);
- /*
- * Number of lines
- */
- nl = LENGTH(index);
- for (j=0; j<nl; j++) {
- SEXP indices = VECTOR_ELT(index, j);
- gcontextFromgpar(currentgp, j, &gc, dd);
- /*
- * Number of vertices
- *
- * x and y same length forced in R code
- */
- nx = LENGTH(indices);
- /* Convert the x and y values to CM locations */
- vmax = vmaxget();
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- xold = NA_REAL;
- yold = NA_REAL;
- for (i=0; i<nx; i++) {
- transformLocn(x, y, INTEGER(indices)[i] - 1, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[i]), &(yy[i]));
- /* The graphics engine only takes device coordinates
- */
- xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
- yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
- if ((R_FINITE(xx[i]) && R_FINITE(yy[i])) &&
- !(R_FINITE(xold) && R_FINITE(yold)))
- start = i;
- else if ((R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx[i]) && R_FINITE(yy[i]))) {
- if (i-start > 1) {
- GEPolyline(i-start, xx+start, yy+start, &gc, dd);
- if (!isNull(arrow)) {
- /*
- * Can draw an arrow at the start if the points
- * include the first point.
- * CANNOT draw an arrow at the end point
- * because we have just broken the line for an NA.
- */
- arrows(xx+start, yy+start, i-start,
- arrow, j, start == 0, FALSE,
- vpc, vpWidthCM, vpHeightCM, &gc, dd);
- }
- }
- }
- else if ((R_FINITE(xold) && R_FINITE(yold)) &&
- (i == nx-1)) {
- GEPolyline(nx-start, xx+start, yy+start, &gc, dd);
- if (!isNull(arrow)) {
- /*
- * Can draw an arrow at the start if the points
- * include the first point.
- * Can draw an arrow at the end point.
- */
- arrows(xx+start, yy+start, nx-start,
- arrow, j, start == 0, TRUE,
- vpc, vpWidthCM, vpHeightCM, &gc, dd);
- }
- }
- xold = xx[i];
- yold = yy[i];
- }
- vmaxset(vmax);
- }
- GEMode(0, dd);
- return R_NilValue;
-}
-
-/* We are assuming here that the R code has checked that x and y
- * are unit objects
- */
-SEXP gridXspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index,
- double theta, Rboolean draw, Rboolean trace)
-{
- int i, j, nx, np, nloc;
- double *xx, *yy, *ss;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP tracePts = R_NilValue;
- SEXP result = R_NilValue;
- double edgex, edgey;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- /*
- * Number of xsplines
- */
- np = LENGTH(index);
- PROTECT(tracePts = allocVector(VECSXP, np));
- nloc = 0;
- for (i=0; i<np; i++) {
- const void *vmax;
- SEXP indices = VECTOR_ELT(index, i);
- SEXP points;
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * Number of vertices
- *
- * Check in R code that x and y same length
- */
- nx = LENGTH(indices);
- /* Convert the x and y values to CM locations */
- vmax = vmaxget();
- if (draw)
- GEMode(1, dd);
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- ss = (double *) R_alloc(nx, sizeof(double));
- for (j=0; j<nx; j++) {
- ss[j] = REAL(s)[(INTEGER(indices)[j] - 1) % LENGTH(s)];
- /*
- * If drawing, convert to INCHES on device
- * If just calculating bounds, convert to INCHES within current vp
- */
- if (draw) {
- transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[j]), &(yy[j]));
- } else {
- xx[j] = transformXtoINCHES(x, INTEGER(indices)[j] - 1,
- vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- yy[j] = transformYtoINCHES(y, INTEGER(indices)[j] - 1,
- vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- /* The graphics engine only takes device coordinates
- */
- xx[j] = toDeviceX(xx[j], GE_INCHES, dd);
- yy[j] = toDeviceY(yy[j], GE_INCHES, dd);
- if (!(R_FINITE(xx[j]) && R_FINITE(yy[j]))) {
- error(_("non-finite control point in Xspline"));
- }
- }
- PROTECT(points = GEXspline(nx, xx, yy, ss,
- LOGICAL(o)[0], LOGICAL(rep)[0],
- draw, &gc, dd));
- {
- /*
- * In some cases, GEXspline seems to produce identical points
- * (at least observed at end of spline)
- * so trim identical points from the ends
- * (so arrow heads are drawn at correct angle)
- */
- int np = LENGTH(VECTOR_ELT(points, 0));
- double *px = REAL(VECTOR_ELT(points, 0));
- double *py = REAL(VECTOR_ELT(points, 1));
- int start = 0;
- int end = np - 1;
- /*
- * DEBUGGING ...
- int k;
- for (k=0; k<np; k++) {
- GESymbol(px[k], py[k], 16, 3, &gc, dd);
- }
- * ... DEBUGGING
- */
- while (np > 1 &&
- (px[start] == px[start + 1]) &&
- (py[start] == py[start + 1])) {
- start++;
- np--;
- }
- while (np > 1 &&
- (px[end] == px[end - 1]) &&
- (py[end] == py[end - 1])) {
- end--;
- np--;
- }
- if (trace) {
- int k;
- int count = end - start + 1;
- double *keepXptr, *keepYptr;
- SEXP keepPoints, keepX, keepY;
- PROTECT(keepPoints = allocVector(VECSXP, 2));
- PROTECT(keepX = allocVector(REALSXP, count));
- PROTECT(keepY = allocVector(REALSXP, count));
- keepXptr = REAL(keepX);
- keepYptr = REAL(keepY);
- for (k=start; k<(end + 1); k++) {
- keepXptr[k - start] = fromDeviceX(px[k], GE_INCHES, dd);
- keepYptr[k - start] = fromDeviceY(py[k], GE_INCHES, dd);
- }
- SET_VECTOR_ELT(keepPoints, 0, keepX);
- SET_VECTOR_ELT(keepPoints, 1, keepY);
- SET_VECTOR_ELT(tracePts, i, keepPoints);
- UNPROTECT(3); /* keepPoints & keepX & keepY */
- }
- if (draw && !isNull(a) && !isNull(points)) {
- /*
- * Can draw an arrow at the either end.
- */
- arrows(&(px[start]), &(py[start]), np,
- a, i, TRUE, TRUE,
- vpc, vpWidthCM, vpHeightCM, &gc, dd);
- }
- if (!draw && !trace && !isNull(points)) {
- /*
- * Update bounds
- */
- int j, n = LENGTH(VECTOR_ELT(points, 0));
- double *pxx = (double *) R_alloc(n, sizeof(double));
- double *pyy = (double *) R_alloc(n, sizeof(double));
- for (j=0; j<n; j++) {
- pxx[j] = fromDeviceX(px[j], GE_INCHES, dd);
- pyy[j] = fromDeviceY(py[j], GE_INCHES, dd);
- if (R_FINITE(pxx[j]) && R_FINITE(pyy[j])) {
- if (pxx[j] < xmin)
- xmin = pxx[j];
- if (pxx[j] > xmax)
- xmax = pxx[j];
- if (pyy[j] < ymin)
- ymin = pyy[j];
- if (pyy[j] > ymax)
- ymax = pyy[j];
- nloc++;
- }
- }
- /*
- * Calculate edgex and edgey for case where this is
- * the only xspline
- */
- hullEdge(pxx, pyy, n, theta, &edgex, &edgey);
- }
- } /* End of trimming-redundant-points code */
- UNPROTECT(1); /* points */
- if (draw)
- GEMode(0, dd);
- vmaxset(vmax);
- }
- if (!draw && !trace && nloc > 0) {
- PROTECT(result = allocVector(REALSXP, 4));
- /*
- * If there is more than one xspline, just produce edge
- * based on bounding rect of all xsplines
- */
- if (np > 1) {
- rectEdge(xmin, ymin, xmax, ymax, theta,
- &edgex, &edgey);
- }
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(result)[0] = edgex /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[1] = edgey /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[2] = (xmax - xmin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[3] = (ymax - ymin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- UNPROTECT(1); /* result */
- } else if (trace) {
- result = tracePts;
- }
- UNPROTECT(1); /* tracePts */
- return result;
-}
-
-SEXP L_xspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index)
-{
- gridXspline(x, y, s, o, a, rep, index, 0, TRUE, FALSE);
- return R_NilValue;
-}
-
-SEXP L_xsplineBounds(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
- SEXP index, SEXP theta)
-{
- return gridXspline(x, y, s, o, a, rep, index, REAL(theta)[0],
- FALSE, FALSE);
-}
-
-SEXP L_xsplinePoints(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
- SEXP index, SEXP theta)
-{
- return gridXspline(x, y, s, o, a, rep, index, REAL(theta)[0],
- FALSE, TRUE);
-}
-
-SEXP L_segments(SEXP x0, SEXP y0, SEXP x1, SEXP y1, SEXP arrow)
-{
- int i, nx0, ny0, nx1, ny1, maxn;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- maxn = nx0 = unitLength(x0);
- ny0 = unitLength(y0);
- nx1 = unitLength(x1);
- ny1 = unitLength(y1);
- if (ny0 > maxn)
- maxn = ny0;
- if (nx1 > maxn)
- maxn = nx1;
- if (ny1 > maxn)
- maxn = ny1;
- /* Convert the x and y values to INCHES locations */
- /* FIXME: Need to check for NaN's and NA's
- */
- GEMode(1, dd);
- for (i=0; i<maxn; i++) {
- double xx0, yy0, xx1, yy1;
- gcontextFromgpar(currentgp, i, &gc, dd);
- transformLocn(x0, y0, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xx0, &yy0);
- transformLocn(x1, y1, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xx1, &yy1);
- /* The graphics engine only takes device coordinates
- */
- xx0 = toDeviceX(xx0, GE_INCHES, dd);
- yy0 = toDeviceY(yy0, GE_INCHES, dd);
- xx1 = toDeviceX(xx1, GE_INCHES, dd);
- yy1 = toDeviceY(yy1, GE_INCHES, dd);
- if (R_FINITE(xx0) && R_FINITE(yy0) &&
- R_FINITE(xx1) && R_FINITE(yy1)) {
- GELine(xx0, yy0, xx1, yy1, &gc, dd);
- if (!isNull(arrow)) {
- double ax[2], ay[2];
- ax[0] = xx0;
- ax[1] = xx1;
- ay[0] = yy0;
- ay[1] = yy1;
- arrows(ax, ay, 2,
- arrow, i, TRUE, TRUE,
- vpc, vpWidthCM, vpHeightCM, &gc, dd);
- }
- }
- }
- GEMode(0, dd);
- return R_NilValue;
-}
-
-static int getArrowN(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
- SEXP y1, SEXP y2, SEXP ynm1, SEXP yn)
-{
- int nx2, nxnm1, nxn, ny1, ny2, nynm1, nyn, maxn;
- maxn = 0;
- /*
- * x1, y1, xnm1, and ynm1 could be NULL if this is adding
- * arrows to a line.to
- */
- if (isNull(y1))
- ny1 = 0;
- else
- ny1 = unitLength(y1);
- nx2 = unitLength(x2);
- ny2 = unitLength(y2);
- if (isNull(xnm1))
- nxnm1 = 0;
- else
- nxnm1 = unitLength(xnm1);
- if (isNull(ynm1))
- nynm1 = 0;
- else
- nynm1 = unitLength(ynm1);
- nxn = unitLength(xn);
- nyn = unitLength(yn);
- if (ny1 > maxn)
- maxn = ny1;
- if (nx2 > maxn)
- maxn = nx2;
- if (ny2 > maxn)
- maxn = ny2;
- if (nxnm1 > maxn)
- maxn = nxnm1;
- if (nynm1 > maxn)
- maxn = nynm1;
- if (nxn > maxn)
- maxn = nxn;
- if (nyn > maxn)
- maxn = nyn;
- return maxn;
-}
-
-SEXP L_arrows(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
- SEXP y1, SEXP y2, SEXP ynm1, SEXP yn,
- SEXP angle, SEXP length, SEXP ends, SEXP type)
-{
- int i, maxn;
- int ne;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- Rboolean first, last;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP devloc = R_NilValue; /* -Wall */
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- maxn = getArrowN(x1, x2, xnm1, xn,
- y1, y2, ynm1, yn);
- ne = LENGTH(ends);
- /* Convert the x and y values to INCHES locations */
- /* FIXME: Need to check for NaN's and NA's
- */
- GEMode(1, dd);
- for (i=0; i<maxn; i++) {
- double xx1, xx2, xxnm1, xxn, yy1, yy2, yynm1, yyn;
- double vertx[3];
- double verty[3];
- first = TRUE;
- last = TRUE;
- switch (INTEGER(ends)[i % ne]) {
- case 2:
- first = FALSE;
- break;
- case 1:
- last = FALSE;
- break;
- }
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * If we're adding arrows to a line.to
- * x1 will be NULL
- */
- if (isNull(x1))
- PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
- if (first) {
- if (isNull(x1)) {
- xx1 = REAL(devloc)[0];
- yy1 = REAL(devloc)[1];
- } else
- transformLocn(x1, y1, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xx1, &yy1);
- transformLocn(x2, y2, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xx2, &yy2);
- calcArrow(xx1, yy1, xx2, yy2, angle, length, i,
- vpc, vpWidthCM, vpHeightCM,
- vertx, verty, &gc, dd);
- /*
- * Only draw arrow if both ends of first segment
- * are not non-finite
- */
- if (R_FINITE(toDeviceX(xx2, GE_INCHES, dd)) &&
- R_FINITE(toDeviceY(yy2, GE_INCHES, dd)) &&
- R_FINITE(vertx[1]) && R_FINITE(verty[1]))
- drawArrow(vertx, verty, type, i, &gc, dd);
- }
- if (last) {
- if (isNull(xnm1)) {
- xxnm1 = REAL(devloc)[0];
- yynm1 = REAL(devloc)[1];
- } else
- transformLocn(xnm1, ynm1, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xxnm1, &yynm1);
- transformLocn(xn, yn, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, transform, &xxn, &yyn);
- calcArrow(xxn, yyn, xxnm1, yynm1, angle, length, i,
- vpc, vpWidthCM, vpHeightCM,
- vertx, verty, &gc, dd);
- /*
- * Only draw arrow if both ends of laste segment are
- * not non-finite
- */
- if (R_FINITE(toDeviceX(xxnm1, GE_INCHES, dd)) &&
- R_FINITE(toDeviceY(yynm1, GE_INCHES, dd)) &&
- R_FINITE(vertx[1]) && R_FINITE(verty[1]))
- drawArrow(vertx, verty, type, i, &gc, dd);
- }
- if (isNull(x1))
- UNPROTECT(1);
- }
- GEMode(0, dd);
- return R_NilValue;
-}
-
-SEXP L_polygon(SEXP x, SEXP y, SEXP index)
-{
- int i, j, nx, np, start=0;
- double *xx, *yy;
- double xold, yold;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- GEMode(1, dd);
- /*
- * Number of polygons
- */
- np = LENGTH(index);
- for (i=0; i<np; i++) {
- const void *vmax;
- SEXP indices = VECTOR_ELT(index, i);
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * Number of vertices
- *
- * Check in R code that x and y same length
- */
- nx = LENGTH(indices);
- /* Convert the x and y values to CM locations */
- vmax = vmaxget();
- xx = (double *) R_alloc(nx + 1, sizeof(double));
- yy = (double *) R_alloc(nx + 1, sizeof(double));
- xold = NA_REAL;
- yold = NA_REAL;
- for (j=0; j<nx; j++) {
- transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[j]), &(yy[j]));
- /* The graphics engine only takes device coordinates
- */
- xx[j] = toDeviceX(xx[j], GE_INCHES, dd);
- yy[j] = toDeviceY(yy[j], GE_INCHES, dd);
- if ((R_FINITE(xx[j]) && R_FINITE(yy[j])) &&
- !(R_FINITE(xold) && R_FINITE(yold)))
- start = j; /* first point of current segment */
- else if ((R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx[j]) && R_FINITE(yy[j]))) {
- if (j-start > 1) {
- GEPolygon(j-start, xx+start, yy+start, &gc, dd);
- }
- }
- else if ((R_FINITE(xold) && R_FINITE(yold)) && (j == nx-1)) {
- /* last */
- GEPolygon(nx-start, xx+start, yy+start, &gc, dd);
- }
- xold = xx[j];
- yold = yy[j];
- }
- vmaxset(vmax);
- }
- GEMode(0, dd);
- return R_NilValue;
-}
-
-static SEXP gridCircle(SEXP x, SEXP y, SEXP r,
- double theta, Rboolean draw)
-{
- int i, nx, ny, nr, ncirc;
- double xx, yy, rr1, rr2, rr = 0.0 /* -Wall */;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP result = R_NilValue;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- double edgex, edgey;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- nx = unitLength(x);
- ny = unitLength(y);
- nr = unitLength(r);
- if (ny > nx)
- nx = ny;
- if (nr > nx)
- nx = nr;
- if (draw) {
- GEMode(1, dd);
- }
- ncirc = 0;
- for (i=0; i<nx; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * If drawing, convert to INCHES on device
- * If just calculating bounds, convert to INCHES within current vp
- */
- if (draw) {
- transformLocn(x, y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- } else {
- xx = transformXtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- yy = transformYtoINCHES(y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- /* These two will give the same answer unless r is in "native",
- * "npc", or some other relative units; in those cases, just
- * take the smaller of the two values.
- */
- rr1 = transformWidthtoINCHES(r, i % nr, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- rr2 = transformHeighttoINCHES(r, i % nr, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- /*
- * A negative radius is silently converted to absolute value
- */
- rr = fmin2(fabs(rr1), fabs(rr2));
- if (R_FINITE(xx) && R_FINITE(yy) && R_FINITE(rr)) {
- if (draw) {
- /* The graphics engine only takes device coordinates
- */
- xx = toDeviceX(xx, GE_INCHES, dd);
- yy = toDeviceY(yy, GE_INCHES, dd);
- rr = toDeviceWidth(rr, GE_INCHES, dd);
- GECircle(xx, yy, rr, &gc, dd);
- } else {
- if (xx + rr < xmin)
- xmin = xx + rr;
- if (xx + rr > xmax)
- xmax = xx + rr;
- if (xx - rr < xmin)
- xmin = xx - rr;
- if (xx - rr > xmax)
- xmax = xx - rr;
- if (yy + rr < ymin)
- ymin = yy + rr;
- if (yy + rr > ymax)
- ymax = yy + rr;
- if (yy - rr < ymin)
- ymin = yy - rr;
- if (yy - rr > ymax)
- ymax = yy - rr;
- ncirc++;
- }
- }
- }
- if (draw) {
- GEMode(0, dd);
- } else if (ncirc > 0) {
- result = allocVector(REALSXP, 4);
- if (ncirc == 1) {
- /*
- * Produce edge of actual circle
- */
- circleEdge(xx, yy, rr, theta, &edgex, &edgey);
- } else {
- /*
- * Produce edge of rect bounding all circles
- */
- rectEdge(xmin, ymin, xmax, ymax, theta,
- &edgex, &edgey);
- }
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(result)[0] = edgex /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[1] = edgey /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[2] = (xmax - xmin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[3] = (ymax - ymin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- }
- return result;
-}
-
-SEXP L_circle(SEXP x, SEXP y, SEXP r)
-{
- gridCircle(x, y, r, 0, TRUE);
- return R_NilValue;
-}
-
-SEXP L_circleBounds(SEXP x, SEXP y, SEXP r, SEXP theta)
-{
- return gridCircle(x, y, r, REAL(theta)[0], FALSE);
-}
-
-/* We are assuming here that the R code has checked that
- * x, y, w, and h are all unit objects and that vp is a viewport
- */
-static SEXP gridRect(SEXP x, SEXP y, SEXP w, SEXP h,
- SEXP hjust, SEXP vjust, double theta, Rboolean draw)
-{
- double xx, yy, ww, hh;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- int i, ny, nw, nh, maxn, nrect;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP result = R_NilValue;
- double edgex, edgey;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- maxn = unitLength(x);
- ny = unitLength(y);
- nw = unitLength(w);
- nh = unitLength(h);
- if (ny > maxn)
- maxn = ny;
- if (nw > maxn)
- maxn = nw;
- if (nh > maxn)
- maxn = nh;
- if (draw) {
- GEMode(1, dd);
- }
- nrect = 0;
- for (i=0; i<maxn; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * If drawing, convert to INCHES on device
- * If just calculating bounds, convert to INCHES within current vp
- */
- if (draw) {
- transformLocn(x, y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- } else {
- xx = transformXtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- yy = transformYtoINCHES(y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- ww = transformWidthtoINCHES(w, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- hh = transformHeighttoINCHES(h, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- /* If the total rotation angle is zero then we can draw a
- * rectangle as the devices understand rectangles
- * Otherwise we have to draw a polygon equivalent.
- */
- if (draw) {
- if (rotationAngle == 0) {
- xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
- yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
- /* The graphics engine only takes device coordinates
- */
- xx = toDeviceX(xx, GE_INCHES, dd);
- yy = toDeviceY(yy, GE_INCHES, dd);
- ww = toDeviceWidth(ww, GE_INCHES, dd);
- hh = toDeviceHeight(hh, GE_INCHES, dd);
- if (R_FINITE(xx) && R_FINITE(yy) &&
- R_FINITE(ww) && R_FINITE(hh))
- GERect(xx, yy, xx + ww, yy + hh, &gc, dd);
- } else {
- /* We have to do a little bit of work to figure out where the
- * corners of the rectangle are.
- */
- double xxx[5], yyy[5], xadj, yadj;
- double dw, dh;
- SEXP zeroInches, xadjInches, yadjInches, wwInches, hhInches;
- int tmpcol;
- PROTECT(zeroInches = unit(0, L_INCHES));
- /* Find bottom-left location */
- justification(ww, hh,
- REAL(hjust)[i % LENGTH(hjust)],
- REAL(vjust)[i % LENGTH(vjust)],
- &xadj, &yadj);
- PROTECT(xadjInches = unit(xadj, L_INCHES));
- PROTECT(yadjInches = unit(yadj, L_INCHES));
- transformDimn(xadjInches, yadjInches, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, rotationAngle,
- &dw, &dh);
- xxx[0] = xx + dw;
- yyy[0] = yy + dh;
- /* Find top-left location */
- PROTECT(hhInches = unit(hh, L_INCHES));
- transformDimn(zeroInches, hhInches, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, rotationAngle,
- &dw, &dh);
- xxx[1] = xxx[0] + dw;
- yyy[1] = yyy[0] + dh;
- /* Find top-right location */
- PROTECT(wwInches = unit(ww, L_INCHES));
- transformDimn(wwInches, hhInches, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, rotationAngle,
- &dw, &dh);
- xxx[2] = xxx[0] + dw;
- yyy[2] = yyy[0] + dh;
- /* Find bottom-right location */
- transformDimn(wwInches, zeroInches, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, rotationAngle,
- &dw, &dh);
- xxx[3] = xxx[0] + dw;
- yyy[3] = yyy[0] + dh;
- if (R_FINITE(xxx[0]) && R_FINITE(yyy[0]) &&
- R_FINITE(xxx[1]) && R_FINITE(yyy[1]) &&
- R_FINITE(xxx[2]) && R_FINITE(yyy[2]) &&
- R_FINITE(xxx[3]) && R_FINITE(yyy[3])) {
- /* The graphics engine only takes device coordinates
- */
- xxx[0] = toDeviceX(xxx[0], GE_INCHES, dd);
- yyy[0] = toDeviceY(yyy[0], GE_INCHES, dd);
- xxx[1] = toDeviceX(xxx[1], GE_INCHES, dd);
- yyy[1] = toDeviceY(yyy[1], GE_INCHES, dd);
- xxx[2] = toDeviceX(xxx[2], GE_INCHES, dd);
- yyy[2] = toDeviceY(yyy[2], GE_INCHES, dd);
- xxx[3] = toDeviceX(xxx[3], GE_INCHES, dd);
- yyy[3] = toDeviceY(yyy[3], GE_INCHES, dd);
- /* Close the polygon */
- xxx[4] = xxx[0];
- yyy[4] = yyy[0];
- /* Do separate fill and border to avoid border being
- * drawn on clipping boundary when there is a fill
- */
- tmpcol = gc.col;
- gc.col = R_TRANWHITE;
- GEPolygon(5, xxx, yyy, &gc, dd);
- gc.col = tmpcol;
- gc.fill = R_TRANWHITE;
- GEPolygon(5, xxx, yyy, &gc, dd);
- }
- UNPROTECT(5);
- }
- } else { /* Just calculating boundary */
- xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
- yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
- if (R_FINITE(xx) && R_FINITE(yy) &&
- R_FINITE(ww) && R_FINITE(hh)) {
- if (xx < xmin)
- xmin = xx;
- if (xx > xmax)
- xmax = xx;
- if (xx + ww < xmin)
- xmin = xx + ww;
- if (xx + ww > xmax)
- xmax = xx + ww;
- if (yy < ymin)
- ymin = yy;
- if (yy > ymax)
- ymax = yy;
- if (yy + hh < ymin)
- ymin = yy + hh;
- if (yy + hh > ymax)
- ymax = yy + hh;
- /*
- * Calculate edgex and edgey for case where this is
- * the only rect
- */
- rectEdge(xx, yy, xx + ww, yy + hh, theta,
- &edgex, &edgey);
- nrect++;
- }
- }
- }
- if (draw) {
- GEMode(0, dd);
- }
- if (nrect > 0) {
- result = allocVector(REALSXP, 4);
- /*
- * If there is more than one rect, just produce edge
- * based on bounding rect of all rects
- */
- if (nrect > 1) {
- rectEdge(xmin, ymin, xmax, ymax, theta,
- &edgex, &edgey);
- }
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(result)[0] = edgex /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[1] = edgey /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[2] = (xmax - xmin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[3] = (ymax - ymin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- }
- return result;
-}
-
-SEXP L_rect(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust)
-{
- gridRect(x, y, w, h, hjust, vjust, 0, TRUE);
- return R_NilValue;
-}
-
-SEXP L_rectBounds(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust,
- SEXP theta)
-{
- return gridRect(x, y, w, h, hjust, vjust, REAL(theta)[0], FALSE);
-}
-
-/* FIXME: need to add L_pathBounds ? */
-
-SEXP L_path(SEXP x, SEXP y, SEXP index, SEXP rule)
-{
- int i, j, k, npoly, *nper, ntot;
- double *xx, *yy;
- const void *vmax;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- GEMode(1, dd);
- vmax = vmaxget();
- /*
- * Number of polygons
- */
- npoly = LENGTH(index);
- /*
- * Total number of points and
- * Number of points per polygon
- */
- ntot = 0;
- nper = (int *) R_alloc(npoly, sizeof(int));
- for (i=0; i < npoly; i++) {
- nper[i] = LENGTH(VECTOR_ELT(index, i));
- ntot = ntot + nper[i];
- }
- xx = (double *) R_alloc(ntot, sizeof(double));
- yy = (double *) R_alloc(ntot, sizeof(double));
- k = 0;
- for (i=0; i < npoly; i++) {
- SEXP indices = VECTOR_ELT(index, i);
- for (j=0; j < nper[i]; j++) {
- transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[k]), &(yy[k]));
- /* The graphics engine only takes device coordinates
- */
- xx[k] = toDeviceX(xx[k], GE_INCHES, dd);
- yy[k] = toDeviceY(yy[k], GE_INCHES, dd);
- /* NO NA values allowed in 'x' or 'y'
- */
- if (!R_FINITE(xx[k]) || !R_FINITE(yy[k]))
- error(_("non-finite x or y in graphics path"));
- k++;
- }
- }
- gcontextFromgpar(currentgp, 0, &gc, dd);
- GEPath(xx, yy, npoly, nper, INTEGER(rule)[0], &gc, dd);
- vmaxset(vmax);
- GEMode(0, dd);
- return R_NilValue;
-}
-
-/* FIXME: need to add L_rasterBounds */
-
-/* FIXME: Add more checks on correct inputs,
- e.g., Raster should be a matrix of R colors */
-SEXP L_raster(SEXP raster, SEXP x, SEXP y, SEXP w, SEXP h,
- SEXP hjust, SEXP vjust, SEXP interpolate)
-{
- const void *vmax;
- int i, n, ny, nw, nh, maxn;
- double xx, yy, ww, hh;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP dim;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- unsigned int *image;
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- /* Convert the raster matrix to R internal colours */
- n = LENGTH(raster);
- if (n <= 0) {
- error(_("Empty raster"));
- }
- vmax = vmaxget();
- /* raster is rather inefficient so allow a native representation as
- an integer array which requires no conversion */
- if (inherits(raster, "nativeRaster") && isInteger(raster)) {
- image = (unsigned int*) INTEGER(raster);
- } else {
- image = (unsigned int*) R_alloc(n, sizeof(unsigned int));
- for (i=0; i<n; i++) {
- image[i] = RGBpar3(raster, i, R_TRANWHITE);
- }
- }
- dim = getAttrib(raster, R_DimSymbol);
- maxn = unitLength(x);
- ny = unitLength(y);
- nw = unitLength(w);
- nh = unitLength(h);
- if (ny > maxn)
- maxn = ny;
- if (nw > maxn)
- maxn = nw;
- if (nh > maxn)
- maxn = nh;
- GEMode(1, dd);
- for (i=0; i<maxn; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- transformLocn(x, y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- ww = transformWidthtoINCHES(w, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- hh = transformHeighttoINCHES(h, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- if (rotationAngle == 0) {
- xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
- yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
- /* The graphics engine only takes device coordinates
- */
- xx = toDeviceX(xx, GE_INCHES, dd);
- yy = toDeviceY(yy, GE_INCHES, dd);
- ww = toDeviceWidth(ww, GE_INCHES, dd);
- hh = toDeviceHeight(hh, GE_INCHES, dd);
- if (R_FINITE(xx) && R_FINITE(yy) &&
- R_FINITE(ww) && R_FINITE(hh))
- GERaster(image, INTEGER(dim)[1], INTEGER(dim)[0],
- xx, yy, ww, hh, rotationAngle,
- LOGICAL(interpolate)[i % LENGTH(interpolate)],
- &gc, dd);
- } else {
- /* We have to do a little bit of work to figure out where the
- * bottom-left corner of the image is.
- */
- double xbl, ybl, xadj, yadj;
- double dw, dh;
- SEXP xadjInches, yadjInches;
- /* Find bottom-left location */
- justification(ww, hh,
- REAL(hjust)[i % LENGTH(hjust)],
- REAL(vjust)[i % LENGTH(vjust)],
- &xadj, &yadj);
- PROTECT(xadjInches = unit(xadj, L_INCHES));
- PROTECT(yadjInches = unit(yadj, L_INCHES));
- transformDimn(xadjInches, yadjInches, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd, rotationAngle,
- &dw, &dh);
- xbl = xx + dw;
- ybl = yy + dh;
- xbl = toDeviceX(xbl, GE_INCHES, dd);
- ybl = toDeviceY(ybl, GE_INCHES, dd);
- ww = toDeviceWidth(ww, GE_INCHES, dd);
- hh = toDeviceHeight(hh, GE_INCHES, dd);
- if (R_FINITE(xbl) && R_FINITE(ybl) &&
- R_FINITE(ww) && R_FINITE(hh)) {
- /* The graphics engine only takes device coordinates
- */
- GERaster(image, INTEGER(dim)[1], INTEGER(dim)[0],
- xbl, ybl, ww, hh, rotationAngle,
- LOGICAL(interpolate)[i % LENGTH(interpolate)],
- &gc, dd);
- }
- UNPROTECT(2);
- }
- }
- GEMode(0, dd);
- vmaxset(vmax);
- return R_NilValue;
-}
-
-SEXP L_cap()
-{
- int i, col, row, nrow, ncol, size;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- int *rint;
- SEXP raster;
- /* The raster is R internal colours, so convert to
- * R external colours (strings)
- * AND the raster is BY ROW so need to rearrange it
- * to be BY COLUMN (though the dimensions are correct) */
- SEXP image, idim;
-
- PROTECT(raster = GECap(dd));
- /* Non-complying devices will return NULL */
- if (isNull(raster)) {
- image = raster;
- } else {
- size = LENGTH(raster);
- nrow = INTEGER(getAttrib(raster, R_DimSymbol))[0];
- ncol = INTEGER(getAttrib(raster, R_DimSymbol))[1];
-
- PROTECT(image = allocVector(STRSXP, size));
- rint = INTEGER(raster);
- for (i=0; i<size; i++) {
- col = i % ncol + 1;
- row = i / ncol + 1;
- SET_STRING_ELT(image, (col - 1)*nrow + row - 1,
- mkChar(col2name(rint[i])));
- }
-
- PROTECT(idim = allocVector(INTSXP, 2));
- INTEGER(idim)[0] = nrow;
- INTEGER(idim)[1] = ncol;
- setAttrib(image, R_DimSymbol, idim);
-
- UNPROTECT(2);
- }
- UNPROTECT(1);
- return image;
-}
-
-/*
- * Code to draw OR size text
- * Combined to avoid code replication
- */
-static SEXP gridText(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
- SEXP rot, SEXP checkOverlap, double theta, Rboolean draw)
-{
- int i, nx, ny;
- double *xx, *yy;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP txt, result = R_NilValue;
- double edgex, edgey;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- /*
- * Bounding rectangles for checking overlapping
- * Initialised to shut up compiler
- */
- LRect *bounds = NULL;
- LRect trect;
- int numBounds = 0;
- int overlapChecking = LOGICAL(checkOverlap)[0];
- const void *vmax;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- nx = unitLength(x);
- ny = unitLength(y);
- if (ny > nx)
- nx = ny;
- vmax = vmaxget();
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- for (i=0; i<nx; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * If drawing, convert to INCHES on device
- * If just calculating bounds, convert to INCHES within current vp
- */
- if (draw) {
- transformLocn(x, y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[i]), &(yy[i]));
- } else {
- xx[i] = transformXtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- yy[i] = transformYtoINCHES(y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- }
- /* The label can be a string or an expression
- */
- PROTECT(txt = label);
- if (isSymbol(txt) || isLanguage(txt))
- txt = coerceVector(txt, EXPRSXP);
- else if (!isExpression(txt))
- txt = coerceVector(txt, STRSXP);
- if (overlapChecking || !draw) {
- bounds = (LRect *) R_alloc(nx, sizeof(LRect));
- }
- /*
- * Check we have any text to draw
- */
- if (LENGTH(txt) > 0) {
- int ntxt = 0;
- if (draw) {
- /*
- * Drawing text
- */
- GEMode(1, dd);
- }
- for (i=0; i<nx; i++) {
- int doDrawing = 1;
- gcontextFromgpar(currentgp, i, &gc, dd);
- /*
- * Generate bounding boxes when checking for overlap
- * or sizing text
- */
- if (overlapChecking || !draw) {
- int j = 0;
- textRect(xx[i], yy[i], txt, i, &gc,
- REAL(hjust)[i % LENGTH(hjust)],
- REAL(vjust)[i % LENGTH(vjust)],
- /*
- * When calculating bounding rect for text
- * only consider rotation of text within
- * local context, not relative to device
- * (so don't add rotationAngle)
- */
- numeric(rot, i % LENGTH(rot)),
- dd, &trect);
- while (doDrawing && (j < numBounds))
- if (intersect(trect, bounds[j++]))
- doDrawing = 0;
- if (doDrawing) {
- copyRect(trect, &(bounds[numBounds]));
- numBounds++;
- }
- }
- if (draw && doDrawing) {
- /* The graphics engine only takes device coordinates
- */
- xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
- yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
- if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- if (isExpression(txt))
- GEMathText(xx[i], yy[i],
- VECTOR_ELT(txt, i % LENGTH(txt)),
- REAL(hjust)[i % LENGTH(hjust)],
- REAL(vjust)[i % LENGTH(vjust)],
- numeric(rot, i % LENGTH(rot)) +
- rotationAngle,
- &gc, dd);
- else
- GEText(xx[i], yy[i],
- CHAR(STRING_ELT(txt, i % LENGTH(txt))),
- (gc.fontface == 5) ? CE_SYMBOL :
- getCharCE(STRING_ELT(txt, i % LENGTH(txt))),
- REAL(hjust)[i % LENGTH(hjust)],
- REAL(vjust)[i % LENGTH(vjust)],
- numeric(rot, i % LENGTH(rot)) +
- rotationAngle,
- &gc, dd);
- }
- }
- if (!draw) {
- double minx, maxx, miny, maxy;
- /*
- * Sizing text
- */
- if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
- minx = fmin2(trect.x1,
- fmin2(trect.x2,
- fmin2(trect.x3, trect.x4)));
- if (minx < xmin)
- xmin = minx;
- maxx = fmax2(trect.x1,
- fmax2(trect.x2,
- fmax2(trect.x3, trect.x4)));
- if (maxx > xmax)
- xmax = maxx;
- miny = fmin2(trect.y1,
- fmin2(trect.y2,
- fmin2(trect.y3, trect.y4)));
- if (miny < ymin)
- ymin = miny;
- maxy = fmax2(trect.y1,
- fmax2(trect.y2,
- fmax2(trect.y3, trect.y4)));
- if (maxy > ymax)
- ymax = maxy;
- /*
- * Calculate edgex and edgey for case where this is
- * the only rect
- */
- {
- double xxx[4], yyy[4];
- /*
- * Must be in clock-wise order for polygonEdge
- */
- xxx[0] = trect.x4; yyy[0] = trect.y4;
- xxx[1] = trect.x3; yyy[1] = trect.y3;
- xxx[2] = trect.x2; yyy[2] = trect.y2;
- xxx[3] = trect.x1; yyy[3] = trect.y1;
- polygonEdge(xxx, yyy, 4, theta,
- &edgex, &edgey);
- }
- ntxt++;
- }
- }
- }
- if (draw) {
- GEMode(0, dd);
- }
- if (ntxt > 0) {
- result = allocVector(REALSXP, 4);
- /*
- * If there is more than one text, just produce edge
- * based on bounding rect of all text
- */
- if (ntxt > 1) {
- /*
- * Produce edge of rect bounding all text
- */
- rectEdge(xmin, ymin, xmax, ymax, theta,
- &edgex, &edgey);
- }
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(result)[0] = edgex /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[1] = edgey /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[2] = (xmax - xmin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[3] = (ymax - ymin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- }
- }
- vmaxset(vmax);
- UNPROTECT(1);
- return result;
-}
-
-SEXP L_text(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
- SEXP rot, SEXP checkOverlap)
-{
- gridText(label, x, y, hjust, vjust, rot, checkOverlap, 0, TRUE);
- return R_NilValue;
-}
-
-/*
- * Return four values representing boundary of text (which may consist
- * of multiple pieces of text, unaligned, and/or rotated)
- * in INCHES.
- *
- * Result is (xmin, xmax, ymin, ymax)
- *
- * Return NULL if no text to draw; R code will generate unit from that
- */
-SEXP L_textBounds(SEXP label, SEXP x, SEXP y,
- SEXP hjust, SEXP vjust, SEXP rot, SEXP theta)
-{
- SEXP checkOverlap = allocVector(LGLSXP, 1);
- LOGICAL(checkOverlap)[0] = FALSE;
- return gridText(label, x, y, hjust, vjust, rot, checkOverlap,
- REAL(theta)[0], FALSE);
-}
-
-SEXP L_points(SEXP x, SEXP y, SEXP pch, SEXP size)
-{
- int i, nx, npch;
- /* double *xx, *yy;*/
- double *xx, *yy;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- double symbolSize;
- const void *vmax;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- nx = unitLength(x);
- npch = LENGTH(pch);
- /* Convert the x and y values to CM locations */
- vmax = vmaxget();
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- for (i=0; i<nx; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- transformLocn(x, y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &(xx[i]), &(yy[i]));
- /* The graphics engine only takes device coordinates
- */
- xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
- yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
- }
- GEMode(1, dd);
- for (i=0; i<nx; i++)
- if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
- /* FIXME: The symbols will not respond to viewport
- * rotations !!!
- */
- int ipch = NA_INTEGER /* -Wall */;
- gcontextFromgpar(currentgp, i, &gc, dd);
- symbolSize = transformWidthtoINCHES(size, i, vpc, &gc,
- vpWidthCM, vpHeightCM, dd);
- /* The graphics engine only takes device coordinates
- */
- symbolSize = toDeviceWidth(symbolSize, GE_INCHES, dd);
- if (R_FINITE(symbolSize)) {
- /*
- * FIXME:
- * Resolve any differences between this and FixupPch()
- * in plot.c ?
- */
- if (isString(pch)) {
- ipch = GEstring_to_pch(STRING_ELT(pch, i % npch));
- } else if (isInteger(pch)) {
- ipch = INTEGER(pch)[i % npch];
- } else if (isReal(pch)) {
- ipch = R_FINITE(REAL(pch)[i % npch]) ?
- (int) REAL(pch)[i % npch] : NA_INTEGER;
- } else error(_("invalid plotting symbol"));
- /*
- * special case for pch = "."
- */
- if (ipch == 46) symbolSize = gpCex(currentgp, i);
- /*
- * FIXME:
- * For character-based symbols, we need to modify
- * gc->cex so that the FONT size corresponds to
- * the specified symbolSize.
- */
- GESymbol(xx[i], yy[i], ipch, symbolSize, &gc, dd);
- }
- }
- GEMode(0, dd);
- vmaxset(vmax);
- return R_NilValue;
-}
-
-SEXP L_clip(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust)
-{
- double xx, yy, ww, hh;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp, currentClip;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- GEMode(1, dd);
- /*
- * Only set ONE clip rectangle (i.e., NOT vectorised)
- */
- gcontextFromgpar(currentgp, 0, &gc, dd);
- transformLocn(x, y, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd,
- transform,
- &xx, &yy);
- ww = transformWidthtoINCHES(w, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- hh = transformHeighttoINCHES(h, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- /*
- * We can ONLY clip if the total rotation angle is zero.
- */
- if (rotationAngle == 0) {
- xx = justifyX(xx, ww, REAL(hjust)[0]);
- yy = justifyY(yy, hh, REAL(vjust)[0]);
- /* The graphics engine only takes device coordinates
- */
- xx = toDeviceX(xx, GE_INCHES, dd);
- yy = toDeviceY(yy, GE_INCHES, dd);
- ww = toDeviceWidth(ww, GE_INCHES, dd);
- hh = toDeviceHeight(hh, GE_INCHES, dd);
- if (R_FINITE(xx) && R_FINITE(yy) &&
- R_FINITE(ww) && R_FINITE(hh)) {
- GESetClip(xx, yy, xx + ww, yy + hh, dd);
- /*
- * ALSO set the current clip region for the
- * current viewport so that, if a viewport
- * is pushed within the current viewport,
- * when that viewport gets popped again,
- * the clip region returns to what was set
- * by THIS clipGrob (NOT to the current
- * viewport's previous setting)
- */
- PROTECT(currentClip = allocVector(REALSXP, 4));
- REAL(currentClip)[0] = xx;
- REAL(currentClip)[1] = yy;
- REAL(currentClip)[2] = xx + ww;
- REAL(currentClip)[3] = yy + hh;
- SET_VECTOR_ELT(currentvp, PVP_CLIPRECT, currentClip);
- UNPROTECT(1);
- }
- } else {
- warning(_("unable to clip to rotated rectangle"));
- }
- GEMode(0, dd);
- return R_NilValue;
-}
-
-SEXP L_pretty(SEXP scale) {
- double min = numeric(scale, 0);
- double max = numeric(scale, 1);
- double temp;
- /* FIXME: This is just a dummy pointer because we do not have
- * log scales. This will cause death and destruction if it is
- * not addressed when log scales are added !
- */
- double *usr = NULL;
- double axp[3];
- /* FIXME: Default preferred number of ticks hard coded ! */
- int n = 5;
- Rboolean swap = min > max;
- /*
- * Feature:
- * like R, something like xscale = c(100,0) just works
- */
- if(swap) {
- temp = min; min = max; max = temp;
- }
-
- GEPretty(&min, &max, &n);
-
- if(swap) {
- temp = min; min = max; max = temp;
- }
-
- axp[0] = min;
- axp[1] = max;
- axp[2] = n;
- /* FIXME: "log" flag hard-coded to FALSE because we do not
- * have log scales yet
- */
- return Rf_CreateAtVector(axp, usr, n, FALSE);
-}
-
-/*
- * NOTE: This does not go through the graphics engine, but
- * skips straight to the device to obtain a mouse click.
- * This is because I do not want to put a GELocator in the
- * graphics engine; that would be a crappy long term solution.
- * I will wait for a better event-loop/call-back solution before
- * doing something with the graphics engine.
- * This is a stop gap in the meantime.
- *
- * The answer is in INCHES
- */
-
-SEXP L_locator() {
- double x = 0;
- double y = 0;
- SEXP answer;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- GEMode(2, dd);
- PROTECT(answer = allocVector(REALSXP, 2));
- /*
- * Get a mouse click
- * Fails if user did not click mouse button 1
- */
- if(dd->dev->locator && dd->dev->locator(&x, &y, dd->dev)) {
- REAL(answer)[0] = fromDeviceX(x, GE_INCHES, dd);
- REAL(answer)[1] = fromDeviceY(y, GE_INCHES, dd);
- } else {
- REAL(answer)[0] = NA_REAL;
- REAL(answer)[1] = NA_REAL;
- }
- UNPROTECT(1);
- GEMode(0, dd);
- return answer;
-}
-
-/*
- * ****************************************
- * Calculating boundaries of primitives
- *
- * ****************************************
- */
-
-/*
- * Return four values representing boundary of set of locations
- * in INCHES.
- *
- * Result is (xmin, xmax, ymin, ymax)
- *
- * Used for lines, segments, polygons
- */
-SEXP L_locnBounds(SEXP x, SEXP y, SEXP theta)
-{
- int i, nx, ny, nloc;
- double *xx, *yy;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP result = R_NilValue;
- const void *vmax;
- double xmin = DOUBLE_XMAX;
- double xmax = -DOUBLE_XMAX;
- double ymin = DOUBLE_XMAX;
- double ymax = -DOUBLE_XMAX;
- double edgex, edgey;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- nx = unitLength(x);
- ny = unitLength(y);
- if (ny > nx)
- nx = ny;
- nloc = 0;
- vmax = vmaxget();
- if (nx > 0) {
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- for (i=0; i<nx; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- xx[i] = transformXtoINCHES(x, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- yy[i] = transformYtoINCHES(y, i, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- /*
- * Determine min/max x/y values
- */
- if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
- if (xx[i] < xmin)
- xmin = xx[i];
- if (xx[i] > xmax)
- xmax = xx[i];
- if (yy[i] < ymin)
- ymin = yy[i];
- if (yy[i] > ymax)
- ymax = yy[i];
- nloc++;
- }
- }
- }
- if (nloc > 0) {
- hullEdge(xx, yy, nx, REAL(theta)[0], &edgex, &edgey);
- result = allocVector(REALSXP, 4);
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(result)[0] = edgex /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[1] = edgey /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[2] = (xmax - xmin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(result)[3] = (ymax - ymin) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- }
- vmaxset(vmax);
- return result;
-}
-
-/*
- * ****************************************
- * Calculating text metrics
- *
- * ****************************************
- */
-SEXP L_stringMetric(SEXP label)
-{
- int i, n;
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform;
- SEXP currentvp, currentgp;
- SEXP txt;
- SEXP result = R_NilValue;
- SEXP ascent = R_NilValue;
- SEXP descent = R_NilValue;
- SEXP width = R_NilValue;
- const void *vmax;
- double asc, dsc, wid;
- /* Get the current device
- */
- pGEDevDesc dd = getDevice();
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- getViewportContext(currentvp, &vpc);
- /* The label can be a string or an expression: is protected.
- */
- txt = label;
- if (isSymbol(txt) || isLanguage(txt))
- txt = coerceVector(txt, EXPRSXP);
- else if (!isExpression(txt))
- txt = coerceVector(txt, STRSXP);
- PROTECT(txt);
- n = LENGTH(txt);
- vmax = vmaxget();
- PROTECT(ascent = allocVector(REALSXP, n));
- PROTECT(descent = allocVector(REALSXP, n));
- PROTECT(width = allocVector(REALSXP, n));
- if (n > 0) {
- for (i=0; i<n; i++) {
- gcontextFromgpar(currentgp, i, &gc, dd);
- if (isExpression(txt))
- GEExpressionMetric(VECTOR_ELT(txt, i % LENGTH(txt)), &gc,
- &asc, &dsc, &wid,
- dd);
- else
- GEStrMetric(CHAR(STRING_ELT(txt, i)),
- getCharCE(STRING_ELT(txt, i)), &gc,
- &asc, &dsc, &wid,
- dd);
- /*
- * Reverse the scale adjustment (zoom factor)
- * when calculating physical value to return to user-level
- */
- REAL(ascent)[i] = fromDeviceHeight(asc, GE_INCHES, dd) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(descent)[i] = fromDeviceHeight(dsc, GE_INCHES, dd) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- REAL(width)[i] = fromDeviceWidth(wid, GE_INCHES, dd) /
- REAL(gridStateElement(dd, GSS_SCALE))[0];
- }
- }
- PROTECT(result = allocVector(VECSXP, 3));
- SET_VECTOR_ELT(result, 0, ascent);
- SET_VECTOR_ELT(result, 1, descent);
- SET_VECTOR_ELT(result, 2, width);
- vmaxset(vmax);
- UNPROTECT(5);
- return result;
-}
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/grid.h b/com.oracle.truffle.r.native/library/grid/src/grid.h
deleted file mode 100644
index 81ac60047890dfcca406fe824aa035efa3181f51..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/grid.h
+++ /dev/null
@@ -1,633 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-8 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/
- */
-
-#include <Rconfig.h>
-#include <Rinternals.h>
-#include <Rmath.h>
-
-#include <R_ext/Constants.h>
-#include <R_ext/GraphicsEngine.h>
-
-#include <Rinternals.h>
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#define _(String) dgettext ("grid", String)
-#else
-#define _(String) (String)
-#endif
-
-/* All grid type names are prefixed with an "L"
- * All grid global variable names are prefixed with an "L_"
- */
-
-/* This information is stored with R's graphics engine so that
- * grid can have state information per device and grid output can
- * be maintained on multiple devices.
- */
-
-#define GSS_DEVSIZE 0
-#define GSS_CURRLOC 1
-#define GSS_DL 2
-#define GSS_DLINDEX 3
-#define GSS_DLON 4
-#define GSS_GPAR 5
-#define GSS_GPSAVED 6
-#define GSS_VP 7
-#define GSS_GLOBALINDEX 8
-#define GSS_GRIDDEVICE 9
-#define GSS_PREVLOC 10
-#define GSS_ENGINEDLON 11
-#define GSS_CURRGROB 12
-#define GSS_ENGINERECORDING 13
-/* #define GSS_ASK 14 unused in R >= 2.7.0 */
-#define GSS_SCALE 15
-
-/*
- * Structure of a viewport
- */
-#define VP_X 0
-#define VP_Y 1
-#define VP_WIDTH 2
-#define VP_HEIGHT 3
-#define VP_JUST 4
-#define VP_GP 5
-#define VP_CLIP 6
-#define VP_XSCALE 7
-#define VP_YSCALE 8
-#define VP_ANGLE 9
-#define VP_LAYOUT 10
-#define VP_LPOSROW 11
-#define VP_LPOSCOL 12
-#define VP_VALIDJUST 13
-#define VP_VALIDLPOSROW 14
-#define VP_VALIDLPOSCOL 15
-#define VP_NAME 16
-/*
- * Additional structure of a pushedvp
- */
-#define PVP_PARENTGPAR 17
-#define PVP_GPAR 18
-#define PVP_TRANS 19
-#define PVP_WIDTHS 20
-#define PVP_HEIGHTS 21
-#define PVP_WIDTHCM 22
-#define PVP_HEIGHTCM 23
-#define PVP_ROTATION 24
-#define PVP_CLIPRECT 25
-#define PVP_PARENT 26
-#define PVP_CHILDREN 27
-#define PVP_DEVWIDTHCM 28
-#define PVP_DEVHEIGHTCM 29
-
-/*
- * Structure of a layout
- */
-#define LAYOUT_NROW 0
-#define LAYOUT_NCOL 1
-#define LAYOUT_WIDTHS 2
-#define LAYOUT_HEIGHTS 3
-#define LAYOUT_RESPECT 4
-#define LAYOUT_VRESPECT 5
-#define LAYOUT_MRESPECT 6
-#define LAYOUT_JUST 7
-#define LAYOUT_VJUST 8
-
-#define GP_FILL 0
-#define GP_COL 1
-#define GP_GAMMA 2
-#define GP_LTY 3
-#define GP_LWD 4
-#define GP_CEX 5
-#define GP_FONTSIZE 6
-#define GP_LINEHEIGHT 7
-#define GP_FONT 8
-#define GP_FONTFAMILY 9
-#define GP_ALPHA 10
-#define GP_LINEEND 11
-#define GP_LINEJOIN 12
-#define GP_LINEMITRE 13
-#define GP_LEX 14
-/*
- * Keep fontface at the end because it is never used in C code
- */
-#define GP_FONTFACE 15
-
-/*
- * Structure of an arrow description
- */
-#define GRID_ARROWANGLE 0
-#define GRID_ARROWLENGTH 1
-#define GRID_ARROWENDS 2
-#define GRID_ARROWTYPE 3
-
-typedef double LTransform[3][3];
-
-typedef double LLocation[3];
-
-typedef enum {
- L_adding = 1,
- L_subtracting = 2,
- L_summing = 3,
- L_plain = 4,
- L_maximising = 5,
- L_minimising = 6,
- L_multiplying = 7
-} LNullArithmeticMode;
-
-/* NOTE: The order of the enums here must match the order of the
- * strings in unit.R
- */
-typedef enum {
- L_NPC = 0,
- L_CM = 1,
- L_INCHES = 2,
- L_LINES = 3,
- L_NATIVE = 4,
- L_NULL = 5, /* only used in layout specifications (?) */
- L_SNPC = 6,
- L_MM = 7,
- /* Some units based on TeX's definition thereof
- */
- L_POINTS = 8, /* 72.27 pt = 1 in */
- L_PICAS = 9, /* 1 pc = 12 pt */
- L_BIGPOINTS = 10, /* 72 bp = 1 in */
- L_DIDA = 11, /* 1157 dd = 1238 pt */
- L_CICERO = 12, /* 1 cc = 12 dd */
- L_SCALEDPOINTS = 13, /* 65536 sp = 1pt */
- /* Some units which require an object to query for a value.
- */
- L_STRINGWIDTH = 14,
- L_STRINGHEIGHT = 15,
- L_STRINGASCENT = 16,
- L_STRINGDESCENT = 17,
- /* L_LINES now means multiples of the line height.
- * This is multiples of the font size.
- */
- L_CHAR = 18,
- L_GROBX = 19,
- L_GROBY = 20,
- L_GROBWIDTH = 21,
- L_GROBHEIGHT = 22,
- L_GROBASCENT = 23,
- L_GROBDESCENT = 24,
- /*
- * No longer used
- */
- L_MYLINES = 103,
- L_MYCHAR = 104,
- L_MYSTRINGWIDTH = 105,
- L_MYSTRINGHEIGHT = 106
-} LUnit;
-
-typedef enum {
- L_LEFT = 0,
- L_RIGHT = 1,
- L_BOTTOM = 2,
- L_TOP = 3,
- L_CENTRE = 4,
- L_CENTER = 5
-} LJustification;
-
-/* An arbitrarily-oriented rectangle.
- * The vertices are assumed to be in order going anticlockwise
- * around the rectangle.
- */
-typedef struct {
- double x1;
- double x2;
- double x3;
- double x4;
- double y1;
- double y2;
- double y3;
- double y4;
-} LRect;
-
-/* A description of the location of a viewport */
-typedef struct {
- SEXP x;
- SEXP y;
- SEXP width;
- SEXP height;
- double hjust;
- double vjust;
-} LViewportLocation;
-
-/* Components of a viewport which provide coordinate information
- * for children of the viewport
- */
-typedef struct {
- double xscalemin;
- double xscalemax;
- double yscalemin;
- double yscalemax;
-} LViewportContext;
-
-/* Evaluation environment */
-#ifndef GRID_MAIN
-extern SEXP R_gridEvalEnv;
-#else
-SEXP R_gridEvalEnv;
-#endif
-
-
-/* Functions called by R code
- * (from all over the place)
- */
-SEXP L_initGrid(SEXP GridEvalEnv);
-SEXP L_killGrid();
-SEXP L_gridDirty();
-SEXP L_currentViewport();
-SEXP L_setviewport(SEXP vp, SEXP hasParent);
-SEXP L_downviewport(SEXP vp, SEXP strict);
-SEXP L_downvppath(SEXP path, SEXP name, SEXP strict);
-SEXP L_unsetviewport(SEXP last);
-SEXP L_upviewport(SEXP last);
-SEXP L_getDisplayList();
-SEXP L_setDisplayList(SEXP dl);
-SEXP L_getDLelt(SEXP index);
-SEXP L_setDLelt(SEXP value);
-SEXP L_getDLindex();
-SEXP L_setDLindex(SEXP index);
-SEXP L_getDLon();
-SEXP L_setDLon(SEXP value);
-SEXP L_getEngineDLon();
-SEXP L_setEngineDLon(SEXP value);
-SEXP L_getCurrentGrob();
-SEXP L_setCurrentGrob(SEXP value);
-SEXP L_getEngineRecording();
-SEXP L_setEngineRecording(SEXP value);
-SEXP L_currentGPar();
-SEXP L_newpagerecording();
-SEXP L_newpage();
-SEXP L_initGPar();
-SEXP L_initViewportStack();
-SEXP L_initDisplayList();
-SEXP L_convertToNative(SEXP x, SEXP what);
-SEXP L_moveTo(SEXP x, SEXP y);
-SEXP L_lineTo(SEXP x, SEXP y, SEXP arrow);
-SEXP L_lines(SEXP x, SEXP y, SEXP index, SEXP arrow);
-SEXP L_segments(SEXP x0, SEXP y0, SEXP x1, SEXP y1, SEXP arrow);
-SEXP L_arrows(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
- SEXP y1, SEXP y2, SEXP ynm1, SEXP yn,
- SEXP angle, SEXP length, SEXP ends, SEXP type);
-SEXP L_path(SEXP x, SEXP y, SEXP index, SEXP rule);
-SEXP L_polygon(SEXP x, SEXP y, SEXP index);
-SEXP L_xspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index);
-SEXP L_circle(SEXP x, SEXP y, SEXP r);
-SEXP L_rect(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust);
-SEXP L_raster(SEXP raster, SEXP x, SEXP y, SEXP w, SEXP h,
- SEXP hjust, SEXP vjust, SEXP interpolate);
-SEXP L_cap();
-SEXP L_text(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
- SEXP rot, SEXP checkOverlap);
-SEXP L_points(SEXP x, SEXP y, SEXP pch, SEXP size);
-SEXP L_clip(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust);
-SEXP L_pretty(SEXP scale);
-SEXP L_locator();
-SEXP L_convert(SEXP x, SEXP whatfrom,
- SEXP whatto, SEXP unitto);
-SEXP L_layoutRegion(SEXP layoutPosRow, SEXP layoutPosCol);
-
-SEXP L_stringMetric(SEXP label);
-
-/* From matrix.c */
-double locationX(LLocation l);
-
-double locationY(LLocation l);
-
-void copyTransform(LTransform t1, LTransform t2);
-
-void invTransform(LTransform t, LTransform invt);
-
-void identity(LTransform m);
-
-void translation(double tx, double ty, LTransform m);
-
-void scaling(double sx, double sy, LTransform m);
-
-void rotation(double theta, LTransform m);
-
-void multiply(LTransform m1, LTransform m2, LTransform m);
-
-void location(double x, double y, LLocation v);
-
-void trans(LLocation vin, LTransform m, LLocation vout);
-
-/* From unit.c */
-int isUnitArithmetic(SEXP ua);
-
-int isUnitList(SEXP ul);
-
-SEXP unit(double value, int unit);
-
-double unitValue(SEXP unit, int index);
-
-int unitUnit(SEXP unit, int index);
-
-SEXP unitData(SEXP unit, int index);
-
-int unitLength(SEXP u);
-
-extern int L_nullLayoutMode;
-
-double pureNullUnitValue(SEXP unit, int index);
-
-int pureNullUnit(SEXP unit, int index, pGEDevDesc dd);
-
-double transformX(SEXP x, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd);
-
-double transformY(SEXP y, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd);
-
-double transformWidth(SEXP width, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd);
-
-double transformHeight(SEXP height, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd);
-
-double transformXtoINCHES(SEXP x, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd);
-
-double transformYtoINCHES(SEXP y, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd);
-
-void transformLocn(SEXP x, SEXP y, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd,
- LTransform t,
- double *xx, double *yy);
-
-double transformWidthtoINCHES(SEXP w, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd);
-
-double transformHeighttoINCHES(SEXP h, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd);
-
-void transformDimn(SEXP w, SEXP h, int index, LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd,
- double rotationAngle,
- double *ww, double *hh);
-
-double transformXYFromINCHES(double location, int unit,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- pGEDevDesc dd);
-
-double transformWidthHeightFromINCHES(double value, int unit,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- pGEDevDesc dd);
-
-double transformXYtoNPC(double x, int from, double min, double max);
-
-double transformWHtoNPC(double x, int from, double min, double max);
-
-double transformXYfromNPC(double x, int to, double min, double max);
-
-double transformWHfromNPC(double x, int to, double min, double max);
-
-/* From just.c */
-double justifyX(double x, double width, double hjust);
-
-double justifyY(double y, double height, double vjust);
-
-double convertJust(int vjust);
-
-void justification(double width, double height, double hjust, double vjust,
- double *hadj, double *vadj);
-
-/* From util.c */
-SEXP getListElement(SEXP list, char *str);
-
-void setListElement(SEXP list, char *str, SEXP value);
-
-SEXP getSymbolValue(char *symbolName);
-
-void setSymbolValue(char *symbolName, SEXP value);
-
-double numeric(SEXP x, int index);
-
-void rect(double x1, double x2, double x3, double x4,
- double y1, double y2, double y3, double y4,
- LRect *r);
-
-void copyRect(LRect r1, LRect *r);
-
-int intersect(LRect r1, LRect r2);
-
-void textRect(double x, double y, SEXP text, int i,
- const pGEcontext gc,
- double xadj, double yadj,
- double rot, pGEDevDesc dd, LRect *r);
-
-/* From gpar.c */
-double gpFontSize(SEXP gp, int i);
-
-double gpLineHeight(SEXP gp, int i);
-
-int gpCol(SEXP gp, int i);
-
-SEXP gpFillSXP(SEXP gp);
-
-int gpFill(SEXP gp, int i);
-
-double gpGamma(SEXP gp, int i);
-
-int gpLineType(SEXP gp, int i);
-
-double gpLineWidth(SEXP gp, int i);
-
-double gpCex(SEXP gp, int i);
-
-int gpFont(SEXP gp, int i);
-
-const char* gpFontFamily(SEXP gp, int i);
-
-SEXP gpFontSXP(SEXP gp);
-
-SEXP gpFontFamilySXP(SEXP gp);
-
-SEXP gpFontSizeSXP(SEXP gp);
-
-SEXP gpLineHeightSXP(SEXP gp);
-
-void gcontextFromgpar(SEXP gp, int i, const pGEcontext gc, pGEDevDesc dd);
-
-void initGPar(pGEDevDesc dd);
-
-/* From viewport.c */
-SEXP viewportX(SEXP vp);
-
-SEXP viewportY(SEXP vp);
-
-SEXP viewportWidth(SEXP vp);
-
-SEXP viewportHeight(SEXP vp);
-
-SEXP viewportgpar(SEXP vp);
-
-const char* viewportFontFamily(SEXP vp);
-
-int viewportFont(SEXP vp);
-
-double viewportFontSize(SEXP vp);
-
-double viewportLineHeight(SEXP vp);
-
-Rboolean viewportClip(SEXP vp);
-
-SEXP viewportClipRect(SEXP vp);
-
-double viewportXScaleMin(SEXP vp);
-
-double viewportXScaleMax(SEXP vp);
-
-double viewportYScaleMin(SEXP vp);
-
-double viewportYScaleMax(SEXP vp);
-
-double viewportHJust(SEXP v);
-
-double viewportVJust(SEXP vp);
-
-SEXP viewportLayoutPosRow(SEXP vp);
-
-SEXP viewportLayoutPosCol(SEXP vp);
-
-SEXP viewportLayout(SEXP vp);
-
-SEXP viewportParent(SEXP vp);
-
-SEXP viewportTransform(SEXP vp);
-
-SEXP viewportLayoutWidths(SEXP vp);
-
-SEXP viewportLayoutHeights(SEXP vp);
-
-SEXP viewportWidthCM(SEXP vp);
-
-SEXP viewportHeightCM(SEXP vp);
-
-SEXP viewportRotation(SEXP vp);
-
-SEXP viewportParent(SEXP vp);
-
-SEXP viewportChildren(SEXP vp);
-
-SEXP viewportDevWidthCM(SEXP vp);
-
-SEXP viewportDevHeightCM(SEXP vp);
-
-void fillViewportContextFromViewport(SEXP vp, LViewportContext *vpc);
-
-void copyViewportContext(LViewportContext vpc1, LViewportContext *vpc2);
-
-void gcontextFromViewport(SEXP vp, const pGEcontext gc, pGEDevDesc dd);
-
-void calcViewportTransform(SEXP vp, SEXP parent, Rboolean incremental,
- pGEDevDesc dd);
-
-void initVP(pGEDevDesc dd);
-
-/* From layout.c */
-Rboolean checkPosRowPosCol(SEXP viewport, SEXP parent);
-
-void calcViewportLayout(SEXP viewport,
- double parentWidthCM,
- double parentHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd);
-
-void calcViewportLocationFromLayout(SEXP layoutPosRow,
- SEXP layoutPosCol,
- SEXP parent,
- LViewportLocation *vpl);
-
-/* From state.c */
-void initDL(pGEDevDesc dd);
-
-SEXP gridStateElement(pGEDevDesc dd, int elementIndex);
-
-void setGridStateElement(pGEDevDesc dd, int elementIndex, SEXP value);
-
-SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data);
-
-/* From grid.c */
-SEXP doSetViewport(SEXP vp,
- Rboolean topLevelVP,
- Rboolean pushing,
- pGEDevDesc dd);
-
-void getDeviceSize(pGEDevDesc dd, double *devWidthCM, double *devHeightCM);
-
-/* This is, confusingly, a wrapper for GEcurrentDevice */
-pGEDevDesc getDevice();
-
-void getViewportTransform(SEXP currentvp,
- pGEDevDesc dd,
- double *vpWidthCM, double *vpHeightCM,
- LTransform transform, double *rotationAngle);
-
-SEXP L_circleBounds(SEXP x, SEXP y, SEXP r, SEXP theta);
-SEXP L_locnBounds(SEXP x, SEXP y, SEXP theta);
-SEXP L_rectBounds(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust,
- SEXP theta);
-SEXP L_textBounds(SEXP label, SEXP x, SEXP y,
- SEXP hjust, SEXP vjust, SEXP rot, SEXP theta);
-SEXP L_xsplineBounds(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
- SEXP index, SEXP theta);
-SEXP L_xsplinePoints(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
- SEXP index, SEXP theta);
-
-/* From unit.c */
-SEXP validUnits(SEXP units);
-
-/* From gpar.c */
-SEXP L_getGPar(void);
-SEXP L_setGPar(SEXP gpars);
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/just.c b/com.oracle.truffle.r.native/library/grid/src/just.c
deleted file mode 100644
index c005c35956ce30000a09a7fd7f5f4bfc64cb152e..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/just.c
+++ /dev/null
@@ -1,128 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003 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/
- */
-
-#include "grid.h"
-
-/* Modify a location for the correct justification */
-
-/* These tranformations assume that x and width are in the same units */
-/* FIXME: I don't think we check anywhere that a horizontal justification
- * is not L_BOTTOM or L_TOP (i.e., meaningless). Ditto for checking
- * vertical justification.
- */
-double justifyX(double x, double width, double hjust) {
- return x - width*hjust;
- /*
- * From when hjust and vjust were enums
- *
- double result = 0;
- switch (hjust) {
- case L_LEFT:
- result = x;
- break;
- case L_RIGHT:
- result = x - width;
- break;
- case L_CENTRE:
- case L_CENTER:
- result = x - width/2;
- break;
- }
- return result;
- */
-}
-
-double justifyY(double y, double height, double vjust) {
- return y - height*vjust;
- /*
- * From when hjust and vjust were enums
- *
- double result = 0;
- switch (vjust) {
- case L_BOTTOM:
- result = y;
- break;
- case L_TOP:
- result = y - height;
- break;
- case L_CENTRE:
- case L_CENTER:
- result = y - height/2;
- break;
- }
- return result;
- */
-}
-
-/* Convert enum justification into 0..1 justification */
-double convertJust(int just) {
- double result = 0;
- switch (just) {
- case L_BOTTOM:
- case L_LEFT:
- result = 0;
- break;
- case L_CENTRE:
- case L_CENTER:
- result = .5;
- break;
- case L_TOP:
- case L_RIGHT:
- result = 1;
- break;
- }
- return result;
-}
-
-/* Return the amount of justification required
- */
-void justification(double width, double height, double hjust, double vjust,
- double *hadj, double *vadj)
-{
- *hadj = -width*hjust;
- *vadj = -height*vjust;
- /*
- * From when hjust and vjust were enums
- switch (hjust) {
- case L_LEFT:
- *hadj = 0;
- break;
- case L_RIGHT:
- *hadj = -width;
- break;
- case L_CENTRE:
- case L_CENTER:
- *hadj = -width/2;
- break;
- }
- switch (vjust) {
- case L_BOTTOM:
- *vadj = 0;
- break;
- case L_TOP:
- *vadj = -height;
- break;
- case L_CENTRE:
- case L_CENTER:
- *vadj = -height/2;
- break;
- }
- */
-}
diff --git a/com.oracle.truffle.r.native/library/grid/src/layout.c b/com.oracle.truffle.r.native/library/grid/src/layout.c
deleted file mode 100644
index f338862e7b1e2e5317fc52e1a9fab74cb3bd664b..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/layout.c
+++ /dev/null
@@ -1,648 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-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.
- *
- * 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/
- */
-
-#include "grid.h"
-
-/* This stuff always returns an LViewportLocation in "npc" units
- */
-
-int layoutNRow(SEXP l) {
- return INTEGER(VECTOR_ELT(l, LAYOUT_NROW))[0];
-}
-
-int layoutNCol(SEXP l) {
- return INTEGER(VECTOR_ELT(l, LAYOUT_NCOL))[0];
-}
-
-SEXP layoutWidths(SEXP l) {
- return VECTOR_ELT(l, LAYOUT_WIDTHS);
-}
-
-SEXP layoutHeights(SEXP l) {
- return VECTOR_ELT(l, LAYOUT_HEIGHTS);
-}
-
-int layoutRespect(SEXP l) {
- return INTEGER(VECTOR_ELT(l, LAYOUT_VRESPECT))[0];
-}
-
-int* layoutRespectMat(SEXP l) {
- return INTEGER(VECTOR_ELT(l, LAYOUT_MRESPECT));
-}
-
-double layoutHJust(SEXP l) {
- return REAL(VECTOR_ELT(l, LAYOUT_VJUST))[0];
-}
-
-double layoutVJust(SEXP l) {
- return REAL(VECTOR_ELT(l, LAYOUT_VJUST))[1];
-}
-
-Rboolean relativeUnit(SEXP unit, int index,
- pGEDevDesc dd) {
- return pureNullUnit(unit, index, dd);
-}
-
-void findRelWidths(SEXP layout, int *relativeWidths,
- pGEDevDesc dd)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- for (i=0; i<layoutNCol(layout); i++)
- relativeWidths[i] = relativeUnit(widths, i, dd);
-}
-
-void findRelHeights(SEXP layout, int *relativeHeights,
- pGEDevDesc dd)
-{
- int i;
- SEXP heights = layoutHeights(layout);
- for (i=0; i<layoutNRow(layout); i++)
- relativeHeights[i] = relativeUnit(heights, i, dd);
-}
-
-void allocateKnownWidths(SEXP layout,
- int *relativeWidths,
- double parentWidthCM, double parentHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd,
- double *npcWidths, double *widthLeftCM)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- for (i=0; i<layoutNCol(layout); i++)
- if (!relativeWidths[i]) {
- npcWidths[i] = transformWidth(widths, i, parentContext,
- parentgc,
- parentWidthCM, parentHeightCM,
- 0, 0, dd)*2.54;
- *widthLeftCM -= npcWidths[i];
- }
-}
-
-void allocateKnownHeights(SEXP layout,
- int *relativeHeights,
- double parentWidthCM, double parentHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd,
- double *npcHeights, double *heightLeftCM)
-{
- int i;
- SEXP heights = layoutHeights(layout);
- for (i=0; i<layoutNRow(layout); i++)
- if (!relativeHeights[i]) {
- npcHeights[i] = transformHeight(heights, i, parentContext,
- parentgc,
- parentWidthCM, parentHeightCM,
- 0, 0, dd)*2.54;
- *heightLeftCM -= npcHeights[i];
- }
-}
-
-int colRespected(int col, SEXP layout) {
- int i;
- int result = 0;
- int respect = layoutRespect(layout);
- int *respectMat = layoutRespectMat(layout);
- if (respect == 1)
- result = 1;
- else
- for (i=0; i<layoutNRow(layout); i++)
- if (respectMat[col*layoutNRow(layout) + i] != 0)
- result = 1;
- return result;
-}
-
-int rowRespected(int row, SEXP layout) {
- int i;
- int result = 0;
- int respect = layoutRespect(layout);
- int *respectMat = layoutRespectMat(layout);
- if (respect == 1)
- result = 1;
- else
- for (i=0; i<layoutNCol(layout); i++)
- if (respectMat[i*layoutNRow(layout) + row] != 0)
- result = 1;
- return result;
-}
-
-/*
- * These sum up ALL relative widths and heights (unit = "null")
- * Some effort is made to find all truly null units
- * (e.g., including a grobwidth unit where the grob's width is null)
- */
-double totalWidth(SEXP layout, int *relativeWidths,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- double totalWidth = 0;
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- totalWidth += transformWidth(widths, i, parentContext,
- parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd);
- return totalWidth;
-}
-
-double totalHeight(SEXP layout, int *relativeHeights,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd)
-{
- int i;
- SEXP heights = layoutHeights(layout);
- double totalHeight = 0;
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- totalHeight += transformHeight(heights, i, parentContext,
- parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd);
- return totalHeight;
-}
-
-void allocateRespected(SEXP layout,
- int *relativeWidths, int *relativeHeights,
- double *reducedWidthCM, double *reducedHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd,
- double *npcWidths, double *npcHeights)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- SEXP heights = layoutHeights(layout);
- int respect = layoutRespect(layout);
- double sumWidth = totalWidth(layout, relativeWidths, parentContext,
- parentgc, dd);
- double sumHeight = totalHeight(layout, relativeHeights, parentContext,
- parentgc, dd);
- double denom, mult;
- double tempWidthCM = *reducedWidthCM;
- double tempHeightCM = *reducedHeightCM;
- if (respect > 0) {
- /* Determine whether aspect ratio of available space is
- * bigger or smaller than aspect ratio of layout
- */
- // NB: widths could be zero
- // if ((tempHeightCM / tempWidthCM) > (sumHeight / sumWidth)) {
- if ( tempHeightCM * sumWidth > sumHeight * tempWidthCM) {
- denom = sumWidth;
- mult = tempWidthCM;
- }
- else {
- denom = sumHeight;
- mult = tempHeightCM;
- }
- /* Allocate respected widths
- */
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- if (colRespected(i, layout)) {
- /*
- * Special case of respect, but sumHeight = 0.
- * Action is to allocate widths as if unrespected.
- * Ok to test == 0 because will only be 0 if
- * all relative heights are actually exactly 0.
- */
- if (sumHeight == 0) {
- denom = sumWidth;
- mult = tempWidthCM;
- }
- /* Build a unit SEXP with a single value and no data
- */
- npcWidths[i] = pureNullUnitValue(widths, i) /
- denom*mult;
- *reducedWidthCM -= npcWidths[i];
- }
- /* Allocate respected heights
- */
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- if (rowRespected(i, layout)) {
- /*
- * Special case of respect, but sumWidth = 0.
- * Action is to allocate widths as if unrespected.
- * Ok to test == 0 because will only be 0 if
- * all relative heights are actually exactly 0.
- */
- if (sumWidth == 0) {
- denom = sumHeight;
- mult = tempHeightCM;
- }
- npcHeights[i] = pureNullUnitValue(heights, i) /
- denom*mult;
- *reducedHeightCM -= npcHeights[i];
- }
- }
-}
-
-void setRespectedZero(SEXP layout,
- int *relativeWidths, int *relativeHeights,
- double *npcWidths, double *npcHeights)
-{
- int i;
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- if (colRespected(i, layout))
- npcWidths[i] = 0;
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- if (rowRespected(i, layout))
- npcHeights[i] = 0;
-}
-
-/* These sum up unrespected relative widths and heights (unit = "null")
- */
-double totalUnrespectedWidth(SEXP layout, int *relativeWidths,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- double totalWidth = 0;
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- if (!colRespected(i, layout))
- totalWidth += transformWidth(widths, i, parentContext,
- parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd);
- return totalWidth;
-}
-
-double totalUnrespectedHeight(SEXP layout, int *relativeHeights,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd)
-{
- int i;
- SEXP heights = layoutHeights(layout);
- double totalHeight = 0;
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- if (!rowRespected(i, layout))
- totalHeight += transformHeight(heights, i, parentContext,
- parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd);
- return totalHeight;
-}
-
-
-void setRemainingWidthZero(SEXP layout,
- int *relativeWidths,
- double *npcWidths)
-{
- int i;
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- if (!colRespected(i, layout))
- npcWidths[i] = 0;
-}
-
-void allocateRemainingWidth(SEXP layout, int *relativeWidths,
- double remainingWidthCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd,
- double *npcWidths)
-{
- int i;
- SEXP widths = layoutWidths(layout);
- double sumWidth;
- sumWidth = totalUnrespectedWidth(layout, relativeWidths,
- parentContext, parentgc, dd);
- if (sumWidth > 0) {
- for (i=0; i<layoutNCol(layout); i++)
- if (relativeWidths[i])
- if (!colRespected(i, layout))
- npcWidths[i] = remainingWidthCM*
- transformWidth(widths, i, parentContext, parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd)/
- sumWidth;
- } else {
- /*
- * If ALL relative widths are zero then they all get
- * allocated zero width
- */
- setRemainingWidthZero(layout, relativeWidths, npcWidths);
- }
-}
-
-void setRemainingHeightZero(SEXP layout,
- int *relativeHeights,
- double *npcHeights)
-{
- int i;
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- if (!rowRespected(i, layout))
- npcHeights[i] = 0;
-}
-
-void allocateRemainingHeight(SEXP layout, int *relativeHeights,
- double remainingHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd,
- double *npcHeights)
-{
- int i;
- SEXP heights = layoutHeights(layout);
- double sumHeight;
- sumHeight = totalUnrespectedHeight(layout, relativeHeights,
- parentContext, parentgc, dd);
- if (sumHeight > 0) {
- for (i=0; i<layoutNRow(layout); i++)
- if (relativeHeights[i])
- if (!rowRespected(i, layout))
- npcHeights[i] = remainingHeightCM*
- transformHeight(heights, i, parentContext, parentgc,
- /*
- * NOTE: 0, 0, here is ok
- * because we are only
- * obtaining "null" units
- */
- 0, 0, 1, 0, dd)/
- sumHeight;
- } else {
- /*
- * If ALL relative heights are zero then they all get
- * allocated zero height
- */
- setRemainingHeightZero(layout, relativeHeights, npcHeights);
- }
-}
-
-static double sumDims(double dims[], int from, int to)
-{
- int i;
- double s = 0;
- for (i = from; i < to + 1; i++)
- s = s + dims[i];
- return s;
-}
-
-static void subRegion(SEXP layout,
- int minrow, int maxrow, int mincol, int maxcol,
- double widths[], double heights[],
- double parentWidthCM, double parentHeightCM,
- double *left, double *bottom,
- double *width, double *height)
-{
- double hjust = layoutHJust(layout);
- double vjust = layoutVJust(layout);
- double totalWidth = sumDims(widths, 0, layoutNCol(layout) - 1);
- double totalHeight = sumDims(heights, 0, layoutNRow(layout) - 1);
- *width = sumDims(widths, mincol, maxcol);
- *height = sumDims(heights, minrow, maxrow);
- /* widths and heights are in CM */
- *left = parentWidthCM*hjust - totalWidth*hjust +
- sumDims(widths, 0, mincol - 1);
- *bottom = parentHeightCM*vjust + (1 - vjust)*totalHeight -
- sumDims(heights, 0, maxrow);
- /*
- * From when hjust and vjust were enums
- *
- switch (layoutHJust(layout)) {
- case L_LEFT:
- *left = sumDims(widths, 0, mincol - 1);
- break;
- case L_RIGHT:
- *left = 1 - sumDims(widths, mincol, layoutNCol(layout) - 1);
- break;
- case L_CENTRE:
- case L_CENTER:
- *left = (0.5 - totalWidth/2) + sumDims(widths, 0, mincol - 1);
- break;
- }
- switch (layoutVJust(layout)) {
- case L_BOTTOM:
- *bottom = totalHeight - sumDims(heights, 0, maxrow);
- break;
- case L_TOP:
- *bottom = 1 - sumDims(heights, 0, maxrow);
- break;
- case L_CENTRE:
- case L_CENTER:
- *bottom = (0.5 - totalHeight/2) + totalHeight
- - sumDims(heights, 0, maxrow);
- }
- */
-}
-
-void calcViewportLayout(SEXP viewport,
- double parentWidthCM,
- double parentHeightCM,
- LViewportContext parentContext,
- const pGEcontext parentgc,
- pGEDevDesc dd)
-{
- int i;
- SEXP currentWidths, currentHeights;
- SEXP layout = viewportLayout(viewport);
- double *npcWidths = (double *) R_alloc(layoutNCol(layout), sizeof(double));
- double *npcHeights = (double *) R_alloc(layoutNRow(layout),
- sizeof(double));
- int *relativeWidths = (int *) R_alloc(layoutNCol(layout), sizeof(int));
- int *relativeHeights = (int *) R_alloc(layoutNRow(layout), sizeof(int));
- double reducedWidthCM = parentWidthCM;
- double reducedHeightCM = parentHeightCM;
- /* Figure out which rows and cols have relative heights and widths
- */
- findRelWidths(layout, relativeWidths, dd);
- findRelHeights(layout, relativeHeights, dd);
- /* For any width or height which has a unit other than "null"
- * we can immediately figure out its physical size.
- * We do this and return the widthCM and heightCM
- * remaining after these widths and heights have been allocated
- */
- allocateKnownWidths(layout, relativeWidths,
- parentWidthCM, parentHeightCM,
- parentContext, parentgc,
- dd, npcWidths,
- &reducedWidthCM);
- allocateKnownHeights(layout, relativeHeights,
- parentWidthCM, parentHeightCM,
- parentContext, parentgc,
- dd, npcHeights,
- &reducedHeightCM);
-
- /* Now allocate respected widths and heights and return
- * widthCM and heightCM remaining
- */
- if (reducedWidthCM > 0 ||
- reducedHeightCM > 0) {
- allocateRespected(layout, relativeWidths, relativeHeights,
- &reducedWidthCM, &reducedHeightCM,
- parentContext, parentgc, dd,
- npcWidths, npcHeights);
- } else {
- /*
- * IF EITHER we started with ZERO widthCM and heightCM
- * OR we've used up all the widthCM and heightCM
- * THEN all respected widths/heights get ZERO
- */
- setRespectedZero(layout, relativeWidths, relativeHeights,
- npcWidths, npcHeights);
- }
- /* Now allocate relative widths and heights (unit = "null")
- * in the remaining space
- */
- if (reducedWidthCM > 0) {
- allocateRemainingWidth(layout, relativeWidths,
- reducedWidthCM,
- parentContext, parentgc, dd, npcWidths);
- } else {
- /*
- * IF EITHER we started with ZERO width
- * OR we've used up all the width
- * THEN any relative widths get ZERO
- */
- setRemainingWidthZero(layout, relativeWidths, npcWidths);
- }
- if (reducedHeightCM > 0) {
- allocateRemainingHeight(layout, relativeHeights,
- reducedHeightCM,
- parentContext, parentgc, dd, npcHeights);
- } else {
- /*
- * IF EITHER we started with ZERO height
- * OR we've used up all the height
- * THEN any relative heights get ZERO
- */
- setRemainingHeightZero(layout, relativeHeights, npcHeights);
- }
- /* Record the widths and heights in the viewport
- */
- PROTECT(currentWidths = allocVector(REALSXP, layoutNCol(layout)));
- PROTECT(currentHeights = allocVector(REALSXP, layoutNRow(layout)));
- for (i=0; i<layoutNCol(layout); i++) {
- /* Layout widths are stored in CM
- */
- REAL(currentWidths)[i] = npcWidths[i];
- }
- for (i=0; i<layoutNRow(layout); i++) {
- /* Layout heights are stored in CM
- */
- REAL(currentHeights)[i] = npcHeights[i];
- }
- SET_VECTOR_ELT(viewport, PVP_WIDTHS, currentWidths);
- SET_VECTOR_ELT(viewport, PVP_HEIGHTS, currentHeights);
- UNPROTECT(2);
-}
-
-Rboolean checkPosRowPosCol(SEXP vp, SEXP parent)
-{
- int ncol = layoutNCol(viewportLayout(parent));
- int nrow = layoutNRow(viewportLayout(parent));
- if (!isNull(viewportLayoutPosRow(vp)) &&
- (INTEGER(viewportLayoutPosRow(vp))[0] < 1 ||
- INTEGER(viewportLayoutPosRow(vp))[1] > nrow))
- error(_("invalid 'layout.pos.row'"));
- if (!isNull(viewportLayoutPosCol(vp)) &&
- (INTEGER(viewportLayoutPosCol(vp))[0] < 1 ||
- INTEGER(viewportLayoutPosCol(vp))[1] > ncol))
- error(_("invalid 'layout.pos.col'"));
- return TRUE;
-}
-
-void calcViewportLocationFromLayout(SEXP layoutPosRow,
- SEXP layoutPosCol,
- SEXP parent,
- LViewportLocation *vpl)
-{
- int minrow, maxrow, mincol, maxcol;
- double x, y, width, height;
- SEXP vpx, vpy, vpwidth, vpheight;
- SEXP layout = viewportLayout(parent);
- /* It is possible for ONE of layoutPosRow and layoutPosCol to
- * be NULL; this is interpreted as "occupy all rows/cols"
- * NOTE: The " - 1" is there because R is 1-based and C is zero-based
- */
- if (isNull(layoutPosRow)) {
- minrow = 0;
- maxrow = layoutNRow(layout) - 1;
- } else {
- minrow = INTEGER(layoutPosRow)[0] - 1;
- maxrow = INTEGER(layoutPosRow)[1] - 1;
- }
- if (isNull(layoutPosCol)) {
- mincol = 0;
- maxcol = layoutNCol(layout) - 1;
- } else {
- mincol = INTEGER(layoutPosCol)[0] - 1;
- maxcol = INTEGER(layoutPosCol)[1] - 1;
- }
- /* Put the relevant values into vpl */
- subRegion(viewportLayout(parent), minrow, maxrow, mincol, maxcol,
- REAL(viewportLayoutWidths(parent)),
- REAL(viewportLayoutHeights(parent)),
- REAL(viewportWidthCM(parent))[0],
- REAL(viewportHeightCM(parent))[0],
- &x, &y, &width, &height);
- /* Layout widths and heights are stored in CM
- */
- PROTECT(vpx = unit(x, L_CM));
- vpl->x = vpx;
- PROTECT(vpy = unit(y, L_CM));
- vpl->y = vpy;
- PROTECT(vpwidth = unit(width, L_CM));
- vpl->width = vpwidth;
- PROTECT(vpheight = unit(height, L_CM));
- vpl->height = vpheight;
- vpl->hjust = 0;
- vpl->vjust = 0;
- /* Question: Is there any chance that these newly-allocated
- * unit SEXPs will get corrupted after this unprotect ??
- */
- UNPROTECT(4);
-}
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/matrix.c b/com.oracle.truffle.r.native/library/grid/src/matrix.c
deleted file mode 100644
index edae7088d0d5b5c883a7806515bb3dd1acd46d17..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/matrix.c
+++ /dev/null
@@ -1,153 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003 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/
- */
-
-#include "grid.h"
-
-/* Code for matrices, matrix multiplication, etc for performing
- * 2D affine transformations: translations, scaling, and rotations.
- */
-
-double locationX(LLocation l) {
- return l[0];
-}
-
-double locationY(LLocation l) {
- return l[1];
-}
-
-void copyTransform(LTransform t1, LTransform t2)
-{
- int i, j;
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- t2[i][j] = t1[i][j];
-}
-
-void invTransform(LTransform t, LTransform invt)
-{
- double det = t[0][0]*(t[2][2]*t[1][1] - t[2][1]*t[1][2]) -
- t[1][0]*(t[2][2]*t[0][1] - t[2][1]*t[0][2]) +
- t[2][0]*(t[1][2]*t[0][1] - t[1][1]*t[0][2]);
- if (det == 0)
- error(_("singular transformation matrix"));
- invt[0][0] = 1/det*(t[2][2]*t[1][1] - t[2][1]*t[1][2]);
- invt[0][1] = -1/det*(t[2][2]*t[0][1] - t[2][1]*t[0][2]);
- invt[0][2] = 1/det*(t[1][2]*t[0][1] - t[1][1]*t[0][2]);
- invt[1][0] = -1/det*(t[2][2]*t[1][0] - t[2][0]*t[1][2]);
- invt[1][1] = 1/det*(t[2][2]*t[0][0] - t[2][0]*t[0][2]);
- invt[1][2] = -1/det*(t[1][2]*t[0][0] - t[1][0]*t[0][2]);
- invt[2][0] = 1/det*(t[2][1]*t[1][0] - t[2][0]*t[1][1]);
- invt[2][1] = -1/det*(t[2][1]*t[0][0] - t[2][0]*t[0][1]);
- invt[2][2] = 1/det*(t[1][1]*t[0][0] - t[1][0]*t[0][1]);
-}
-
-void identity(LTransform m)
-{
- int i, j;
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- if (i == j)
- m[i][j] = 1;
- else
- m[i][j] = 0;
-}
-
-void translation(double tx, double ty, LTransform m)
-{
- identity(m);
- m[2][0] = tx;
- m[2][1] = ty;
-}
-
-void scaling(double sx, double sy, LTransform m)
-{
- identity(m);
- m[0][0] = sx;
- m[1][1] = sy;
-}
-
-void rotation(double theta, LTransform m)
-{
- double thetarad = theta/180*M_PI;
- double costheta = cos(thetarad);
- double sintheta = sin(thetarad);
- identity(m);
- m[0][0] = costheta;
- m[0][1] = sintheta;
- m[1][0] = -sintheta;
- m[1][1] = costheta;
-}
-
-void multiply(LTransform m1, LTransform m2, LTransform m)
-{
- m[0][0] = m1[0][0]*m2[0][0] + m1[0][1]*m2[1][0] + m1[0][2]*m2[2][0];
- m[0][1] = m1[0][0]*m2[0][1] + m1[0][1]*m2[1][1] + m1[0][2]*m2[2][1];
- m[0][2] = m1[0][0]*m2[0][2] + m1[0][1]*m2[1][2] + m1[0][2]*m2[2][2];
- m[1][0] = m1[1][0]*m2[0][0] + m1[1][1]*m2[1][0] + m1[1][2]*m2[2][0];
- m[1][1] = m1[1][0]*m2[0][1] + m1[1][1]*m2[1][1] + m1[1][2]*m2[2][1];
- m[1][2] = m1[1][0]*m2[0][2] + m1[1][1]*m2[1][2] + m1[1][2]*m2[2][2];
- m[2][0] = m1[2][0]*m2[0][0] + m1[2][1]*m2[1][0] + m1[2][2]*m2[2][0];
- m[2][1] = m1[2][0]*m2[0][1] + m1[2][1]*m2[1][1] + m1[2][2]*m2[2][1];
- m[2][2] = m1[2][0]*m2[0][2] + m1[2][1]*m2[1][2] + m1[2][2]*m2[2][2];
-}
-
-void location(double x, double y, LLocation v)
-{
- v[0] = x;
- v[1] = y;
- v[2] = 1;
-}
-
-void trans(LLocation vin, LTransform m, LLocation vout)
-{
- vout[0] = vin[0]*m[0][0] + vin[1]*m[1][0] + vin[2]*m[2][0];
- vout[1] = vin[0]*m[0][1] + vin[1]*m[1][1] + vin[2]*m[2][1];
- vout[2] = vin[0]*m[0][2] + vin[1]*m[1][2] + vin[2]*m[2][2];
-}
-
-/* Testing code
- * Need to undocument main() below and add #include <math.h> at top of file
- * Correct answers are "2.67 2.00 1.00" for m4=identity
- * and "0.00 2.00 1.00" for m4=rotation
- */
-
-/*
- main()
- {
- LLocation v1, v2;
- LTransform m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11;
- location(9, 10, v1);
- translation(-5, -6, m1);
- scaling(1/7.0, 1/8.0, m2);
- scaling(7, 8, m3);
- identity(m4);
- rotation(3.141592 / 2, m4);
- translation(4, 4, m5);
- scaling(1/3.0, 1/4.0, m6);
- multiply(m1, m2, m7);
- multiply(m7, m3, m8);
- multiply(m8, m4, m9);
- multiply(m9, m5, m10);
- multiply(m10, m6, m11);
- transform(v1, m11, v2);
- printf("%1.2f %1.2f %1.2f\n", v2[0], v2[1], v2[2]);
- }
-*/
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/register.c b/com.oracle.truffle.r.native/library/grid/src/register.c
deleted file mode 100644
index 43c2075a343db75eecd3af45069f1aea744e6523..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/register.c
+++ /dev/null
@@ -1,100 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-12 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/
- */
-
-/* Code to register grid functions with R
- */
-#include <R_ext/Rdynload.h>
-#include "grid.h"
-
-static const R_CallMethodDef callMethods[] = {
- {"L_initGrid", (DL_FUNC) &L_initGrid, 1},
- {"L_killGrid", (DL_FUNC) &L_killGrid, 0},
- {"L_gridDirty", (DL_FUNC) &L_gridDirty, 0},
- {"L_currentViewport", (DL_FUNC) &L_currentViewport, 0},
- {"L_setviewport", (DL_FUNC) &L_setviewport, 2},
- {"L_downviewport", (DL_FUNC) &L_downviewport, 2},
- {"L_downvppath", (DL_FUNC) &L_downvppath, 3},
- {"L_unsetviewport", (DL_FUNC) &L_unsetviewport, 1},
- {"L_upviewport", (DL_FUNC) &L_upviewport, 1},
- {"L_getDisplayList", (DL_FUNC) &L_getDisplayList, 0},
- {"L_setDisplayList", (DL_FUNC) &L_setDisplayList, 1},
- {"L_getDLelt", (DL_FUNC) &L_getDLelt, 1},
- {"L_setDLelt", (DL_FUNC) &L_setDLelt, 1},
- {"L_getDLindex", (DL_FUNC) &L_getDLindex, 0},
- {"L_setDLindex", (DL_FUNC) &L_setDLindex, 1},
- {"L_getDLon", (DL_FUNC) &L_getDLon, 0},
- {"L_setDLon", (DL_FUNC) &L_setDLon, 1},
- {"L_getEngineDLon", (DL_FUNC) &L_getEngineDLon, 0},
- {"L_setEngineDLon", (DL_FUNC) &L_setEngineDLon, 1},
- {"L_getCurrentGrob", (DL_FUNC) &L_getCurrentGrob, 0},
- {"L_setCurrentGrob", (DL_FUNC) &L_setCurrentGrob, 1},
- {"L_getEngineRecording", (DL_FUNC) &L_getEngineRecording, 0},
- {"L_setEngineRecording", (DL_FUNC) &L_setEngineRecording, 1},
- {"L_currentGPar", (DL_FUNC) &L_currentGPar, 0},
- {"L_newpagerecording", (DL_FUNC) &L_newpagerecording, 0},
- {"L_newpage", (DL_FUNC) &L_newpage, 0},
- {"L_initGPar", (DL_FUNC) &L_initGPar, 0},
- {"L_initViewportStack", (DL_FUNC) &L_initViewportStack, 0},
- {"L_initDisplayList", (DL_FUNC) &L_initDisplayList, 0},
- {"L_moveTo", (DL_FUNC) &L_moveTo, 2},
- {"L_lineTo", (DL_FUNC) &L_lineTo, 3},
- {"L_lines", (DL_FUNC) &L_lines, 4},
- {"L_segments", (DL_FUNC) &L_segments, 5},
- {"L_arrows", (DL_FUNC) &L_arrows, 12},
- {"L_path", (DL_FUNC) &L_path, 4},
- {"L_polygon", (DL_FUNC) &L_polygon, 3},
- {"L_xspline", (DL_FUNC) &L_xspline, 7},
- {"L_circle", (DL_FUNC) &L_circle, 3},
- {"L_rect", (DL_FUNC) &L_rect, 6},
- {"L_raster", (DL_FUNC) &L_raster, 8},
- {"L_cap", (DL_FUNC) &L_cap, 0},
- {"L_text", (DL_FUNC) &L_text, 7},
- {"L_points", (DL_FUNC) &L_points, 4},
- {"L_clip", (DL_FUNC) &L_clip, 6},
- {"L_pretty", (DL_FUNC) &L_pretty, 1},
- {"L_locator", (DL_FUNC) &L_locator, 0},
- {"L_convert", (DL_FUNC) &L_convert, 4},
- {"L_layoutRegion", (DL_FUNC) &L_layoutRegion, 2},
- {"validUnits", (DL_FUNC) &validUnits, 1},
- {"L_getGPar", (DL_FUNC) &L_getGPar, 0},
- {"L_setGPar", (DL_FUNC) &L_setGPar, 1},
- {"L_circleBounds", (DL_FUNC) &L_circleBounds, 4},
- {"L_locnBounds", (DL_FUNC) &L_locnBounds, 3},
- {"L_rectBounds", (DL_FUNC) &L_rectBounds, 7},
- {"L_textBounds", (DL_FUNC) &L_textBounds, 7},
- {"L_xsplineBounds", (DL_FUNC) &L_xsplineBounds, 8},
- {"L_xsplinePoints", (DL_FUNC) &L_xsplinePoints, 8},
- {"L_stringMetric", (DL_FUNC) &L_stringMetric, 1},
- { NULL, NULL, 0 }
-};
-
-
-void
-#ifdef HAVE_VISIBILITY_ATTRIBUTE
-__attribute__ ((visibility ("default")))
-#endif
-R_init_grid(DllInfo *dll)
-{
- /* No .C, .Fortran, or .External routines => NULL
- */
- R_registerRoutines(dll, NULL, callMethods, NULL, NULL);
- R_useDynamicSymbols(dll, FALSE);
- R_forceSymbols(dll, FALSE);
-}
diff --git a/com.oracle.truffle.r.native/library/grid/src/state.c b/com.oracle.truffle.r.native/library/grid/src/state.c
deleted file mode 100644
index a6e68d670e78ae0bc872a3fda106ff3567787457..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/state.c
+++ /dev/null
@@ -1,302 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-5 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/
- */
-
-#include "grid.h"
-
-int gridRegisterIndex;
-
-/* The gridSystemState (per device) consists of
- * GSS_DEVSIZE 0 = current size of device
- * GSS_CURRLOC 1 = current location of grid "pen"
- * GSS_DL 2 = grid display list
- * GSS_DLINDEX 3 = display list index
- * GSS_DLON 4 = is the display list on?
- * GSS_GPAR 5 = gpar settings
- * GSS_GPSAVED 6 = previous gpar settings
- * GSS_VP 7 = viewport
- * GSS_GLOBALINDEX 8 = index of this system state in the global list of states
- * GSS_GRIDDEVICE 9 = does this device contain grid output?
- * GSS_PREVLOC 10 = previous location of grid "pen"
- * GSS_ENGINEDLON 11 = are we using the graphics engine's display list?
- * GSS_CURRGROB 12 = current grob being drawn (for determining
- * the list of grobs to search when evaluating a grobwidth/height
- * unit via gPath)
- * GSS_ENGINERECORDING 13 = are we already inside a .Call.graphics call?
- * Used by grid.Call.graphics to avoid unnecessary recording on
- * engine display list
- * [GSS_ASK 14 = should we prompt the user before starting a new page?
- * Replaced by per-device setting as from R 2.7.0.]
- * GSS_SCALE 15 = a scale or "zoom" factor for all output
- * (to support "fit to window" resizing on windows device)
- *
- * NOTE: if you add to this list you MUST change the size of the vector
- * allocated in createGridSystemState() below.
-*/
-
-SEXP createGridSystemState()
-{
- return allocVector(VECSXP, 16);
-}
-
-void initDL(pGEDevDesc dd)
-{
- SEXP dl, dlindex;
- SEXP vp = gridStateElement(dd, GSS_VP);
- SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- /* The top-level viewport goes at the start of the display list
- */
- PROTECT(dl = allocVector(VECSXP, 100));
- SET_VECTOR_ELT(dl, 0, vp);
- SET_VECTOR_ELT(gsd, GSS_DL, dl);
- PROTECT(dlindex = allocVector(INTSXP, 1));
- INTEGER(dlindex)[0] = 1;
- SET_VECTOR_ELT(gsd, GSS_DLINDEX, dlindex);
- UNPROTECT(2);
-}
-
-/*
- * This is used to init some bits of the system state
- * Called when a grahpics engine redraw is about to occur
- * NOTE that it does not init all of the state, in particular,
- * the display list is not initialised here (see initDL),
- * nor is the ROOT viewport (see initVP),
- * nor is the current gpar (see initGP)
- */
-void initOtherState(pGEDevDesc dd)
-{
- SEXP currloc, prevloc, recording;
- SEXP state = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- currloc = VECTOR_ELT(state, GSS_CURRLOC);
- REAL(currloc)[0] = NA_REAL;
- REAL(currloc)[1] = NA_REAL;
- prevloc = VECTOR_ELT(state, GSS_PREVLOC);
- REAL(prevloc)[0] = NA_REAL;
- REAL(prevloc)[1] = NA_REAL;
- SET_VECTOR_ELT(state, GSS_CURRGROB, R_NilValue);
- recording = VECTOR_ELT(state, GSS_ENGINERECORDING);
- LOGICAL(recording)[0] = FALSE;
- SET_VECTOR_ELT(state, GSS_ENGINERECORDING, recording);
-}
-
-void fillGridSystemState(SEXP state, pGEDevDesc dd)
-{
- SEXP devsize, currloc, prevloc;
-
- PROTECT(state);
- devsize = allocVector(REALSXP, 2);
- REAL(devsize)[0] = 0;
- REAL(devsize)[1] = 0;
- SET_VECTOR_ELT(state, GSS_DEVSIZE, devsize);
- /* "current location"
- * Initial setting relies on the fact that all values sent to devices
- * are in INCHES; so (0, 0) is the bottom-left corner of the device.
- */
- currloc = allocVector(REALSXP, 2);
- REAL(currloc)[0] = NA_REAL;
- REAL(currloc)[1] = NA_REAL;
- SET_VECTOR_ELT(state, GSS_CURRLOC, currloc);
- prevloc = allocVector(REALSXP, 2);
- REAL(prevloc)[0] = NA_REAL;
- REAL(prevloc)[1] = NA_REAL;
- SET_VECTOR_ELT(state, GSS_PREVLOC, prevloc);
- SET_VECTOR_ELT(state, GSS_DLON, ScalarLogical(TRUE));
- SET_VECTOR_ELT(state, GSS_ENGINEDLON, ScalarLogical(TRUE));
- SET_VECTOR_ELT(state, GSS_CURRGROB, R_NilValue);
- SET_VECTOR_ELT(state, GSS_ENGINERECORDING, ScalarLogical(FALSE));
- initGPar(dd);
- SET_VECTOR_ELT(state, GSS_GPSAVED, R_NilValue);
- /* Do NOT initialise top-level viewport or grid display list for
- * this device until there is some grid output
- */
- SET_VECTOR_ELT(state, GSS_GLOBALINDEX, R_NilValue);
- /* Note that no grid output has occurred on the device yet.
- */
- SET_VECTOR_ELT(state, GSS_GRIDDEVICE, ScalarLogical(FALSE));
-#if 0
- SET_VECTOR_ELT(state, GSS_ASK, ScalarLogical(dd->ask));
-#endif
- SET_VECTOR_ELT(state, GSS_SCALE, ScalarReal(1.0));
- UNPROTECT(1);
-}
-
-SEXP gridStateElement(pGEDevDesc dd, int elementIndex)
-{
- return VECTOR_ELT((SEXP) dd->gesd[gridRegisterIndex]->systemSpecific,
- elementIndex);
-}
-
-void setGridStateElement(pGEDevDesc dd, int elementIndex, SEXP value)
-{
- SET_VECTOR_ELT((SEXP) dd->gesd[gridRegisterIndex]->systemSpecific,
- elementIndex, value);
-}
-
-static void deglobaliseState(SEXP state)
-{
- int index = INTEGER(VECTOR_ELT(state, GSS_GLOBALINDEX))[0];
- SET_VECTOR_ELT(findVar(install(".GRID.STATE"), R_gridEvalEnv),
- index, R_NilValue);
-}
-
-static int findStateSlot()
-{
- int i;
- int result = -1;
- SEXP globalstate = findVar(install(".GRID.STATE"), R_gridEvalEnv);
- for (i = 0; i < length(globalstate); i++)
- if (VECTOR_ELT(globalstate, i) == R_NilValue) {
- result = i;
- break;
- }
- if (result < 0)
- error(_("unable to store 'grid' state. Too many devices open?"));
- return result;
-}
-
-static void globaliseState(SEXP state)
-{
- int index = findStateSlot();
- SEXP globalstate, indexsxp;
- PROTECT(globalstate = findVar(install(".GRID.STATE"), R_gridEvalEnv));
- /* Record the index for deglobalisation
- */
- PROTECT(indexsxp = allocVector(INTSXP, 1));
- INTEGER(indexsxp)[0] = index;
- SET_VECTOR_ELT(state, GSS_GLOBALINDEX, indexsxp);
- SET_VECTOR_ELT(globalstate, index, state);
- UNPROTECT(2);
-}
-
-SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data) {
- SEXP result = R_NilValue;
- SEXP valid, scale;
- SEXP gridState;
- GESystemDesc *sd;
- SEXP currentgp;
- SEXP gsd;
- SEXP devsize;
- R_GE_gcontext gc;
- switch (task) {
- case GE_InitState:
- /* Create the initial grid state for a device
- */
- PROTECT(gridState = createGridSystemState());
- /* Store that state with the device for easy retrieval
- */
- sd = dd->gesd[gridRegisterIndex];
- sd->systemSpecific = (void*) gridState;
- /* Initialise the grid state for a device
- */
- fillGridSystemState(gridState, dd);
- /* Also store the state beneath a top-level variable so
- * that it does not get garbage-collected
- */
- globaliseState(gridState);
- /* Indicate success */
- result = R_BlankString;
- UNPROTECT(1);
- break;
- case GE_FinaliseState:
- sd = dd->gesd[gridRegisterIndex];
- /* Simply detach the system state from the global variable
- * and it will be garbage-collected
- */
- deglobaliseState((SEXP) sd->systemSpecific);
- /* Also set the device pointer to NULL
- */
- sd->systemSpecific = NULL;
- break;
- case GE_SaveState:
- break;
- case GE_RestoreState:
- gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- PROTECT(devsize = allocVector(REALSXP, 2));
- getDeviceSize(dd, &(REAL(devsize)[0]), &(REAL(devsize)[1]));
- SET_VECTOR_ELT(gsd, GSS_DEVSIZE, devsize);
- UNPROTECT(1);
- /* Only bother to do any grid drawing setup
- * if there has been grid output
- * on this device.
- */
- if (LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
- if (LOGICAL(gridStateElement(dd, GSS_ENGINEDLON))[0]) {
- /* The graphics engine is about to replay the display list
- * So we "clear" the device and reset the grid graphics state
- */
- /* There are two main situations in which this occurs:
- * (i) a screen is resized
- * In this case, it is ok-ish to do a GENewPage
- * because that has the desired effect and no
- * undesirable effects because it only happens on
- * a screen device -- a new page is the same as
- * clearing the screen
- * (ii) output on one device is copied to another device
- * In this case, a GENewPage is NOT a good thing, however,
- * here we will start with a new device and it will not
- * have any grid output so this section will not get called
- * SO we will not get any unwanted blank pages.
- *
- * All this is a bit fragile; ultimately, what would be ideal
- * is a dev->clearPage primitive for all devices in addition
- * to the dev->newPage primitive
- */
- currentgp = gridStateElement(dd, GSS_GPAR);
- gcontextFromgpar(currentgp, 0, &gc, dd);
- GENewPage(&gc, dd);
- initGPar(dd);
- initVP(dd);
- initOtherState(dd);
- } else {
- /*
- * If we have turned off the graphics engine's display list
- * then we have to redraw the scene ourselves
- */
- SEXP fcall;
- PROTECT(fcall = lang1(install("draw.all")));
- eval(fcall, R_gridEvalEnv);
- UNPROTECT(1);
- }
- }
- break;
- case GE_CopyState:
- break;
- case GE_CheckPlot:
- PROTECT(valid = allocVector(LGLSXP, 1));
- LOGICAL(valid)[0] = TRUE;
- UNPROTECT(1);
- result = valid;
- case GE_SaveSnapshotState:
- break;
- case GE_RestoreSnapshotState:
- break;
- case GE_ScalePS:
- /*
- * data is a numeric scale factor
- */
- PROTECT(scale = allocVector(REALSXP, 1));
- REAL(scale)[0] = REAL(gridStateElement(dd, GSS_SCALE))[0]*
- REAL(data)[0];
- setGridStateElement(dd, GSS_SCALE, scale);
- UNPROTECT(1);
- break;
- }
- return result;
-}
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/unit.c b/com.oracle.truffle.r.native/library/grid/src/unit.c
deleted file mode 100644
index 2d9459ed7bfbbaba33433da90a2a2a31792f3459..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/unit.c
+++ /dev/null
@@ -1,1923 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-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.
- *
- * 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/
- */
-
-#include "grid.h"
-#include <math.h>
-#include <float.h>
-#include <string.h>
-
-int isUnitArithmetic(SEXP ua) {
- return inherits(ua, "unit.arithmetic");
-}
-
-int isUnitList(SEXP ul) {
- return inherits(ul, "unit.list");
-}
-
-/* Function to build a single-value unit SEXP internally.
- * Cannot build units requiring data as yet.
- */
-SEXP unit(double value, int unit)
-{
- SEXP u, units, classname;
- PROTECT(u = ScalarReal(value));
- PROTECT(units = ScalarInteger(unit));
- /* NOTE that we do not set the "unit" attribute */
- setAttrib(u, install("valid.unit"), units);
- setAttrib(u, install("data"), R_NilValue);
- PROTECT(classname = mkString("unit"));
- classgets(u, classname);
- UNPROTECT(3);
- return u;
-}
-
-/* Accessor functions for unit objects
- */
-
-/*
- * This is an attempt to extract a single numeric value from
- * a unit. This is ONLY designed for use on "simple" units
- * (i.e., NOT unitLists or unitArithmetics)
- */
-double unitValue(SEXP unit, int index) {
- /* Recycle values if necessary (used in unit arithmetic)
- */
- int n = LENGTH(unit);
- return numeric(unit, index % n);
-}
-
-int unitUnit(SEXP unit, int index) {
- SEXP units = getAttrib(unit, install("valid.unit"));
- /* Recycle units if necessary
- */
- int n = LENGTH(units);
- return INTEGER(units)[index % n];
-}
-
-SEXP unitData(SEXP unit, int index) {
- SEXP result;
- SEXP data = getAttrib(unit, install("data"));
- if (isNull(data))
- result = R_NilValue;
- else if(TYPEOF(data) == VECSXP) {
- /* Recycle data if necessary
- */
- int n = LENGTH(data);
- result = VECTOR_ELT(data, index % n);
- } else {
- warning("unit attribute 'data' is of incorrect type");
- return R_NilValue;
- }
- return result;
-}
-
-/* Accessor functions for unit arithmetic object
- */
-const char* fName(SEXP ua) {
- return CHAR(STRING_ELT(getListElement(ua, "fname"), 0));
-}
-
-SEXP arg1(SEXP ua) {
- return getListElement(ua, "arg1");
-}
-
-SEXP arg2(SEXP ua) {
- return getListElement(ua, "arg2");
-}
-
-int fNameMatch(SEXP ua, char *aString) {
- return !strcmp(fName(ua), aString);
-}
-
-int addOp(SEXP ua) {
- return fNameMatch(ua, "+");
-}
-
-int minusOp(SEXP ua) {
- return fNameMatch(ua, "-");
-}
-
-int timesOp(SEXP ua) {
- return fNameMatch(ua, "*");
-}
-
-int fOp(SEXP ua) {
- return addOp(ua) || minusOp(ua) || timesOp(ua);
-}
-
-int minFunc(SEXP ua) {
- return fNameMatch(ua, "min");
-}
-
-int maxFunc(SEXP ua) {
- return fNameMatch(ua, "max");
-}
-
-int sumFunc(SEXP ua) {
- return fNameMatch(ua, "sum");
-}
-
-/* Functions in lattice.c should use this to determine the length
- * of a unit/unitArithmetic object rather than just LENGTH.
- */
-int unitLength(SEXP u)
-{
- int result = 0;
- if (isUnitList(u))
- result = LENGTH(u);
- else if (isUnitArithmetic(u))
- if (fOp(u)) {
- if (timesOp(u)) {
- /*
- * arg1 is always the numeric vector
- */
- int n1 = LENGTH(arg1(u));
- int n2 = unitLength(arg2(u));
- result = (n1 > n2) ? n1 : n2;
- } else { /* must be "+" or "-" */
- int n1 = unitLength(arg1(u));
- int n2 = unitLength(arg2(u));
- result = (n1 > n2) ? n1 : n2;
- }
- } else /* must be "min" or "max" or "sum" */
- result = 1; /* unitLength(arg1(u)); */
- else /* Must be a unit object */
- result = LENGTH(u);
- return result;
-}
-
-
-/**************************
- * Code for handling "null" units
- **************************
- */
-
-/* Global mode indicators:
- * The value returned for a "null" unit depends on ...
- * (i) whether layout is calling for evaluation of a "pure null" unit
- * (in which case, the value of the "null" unit is returned)
- * (ii) the sort of arithmetic that is being performed
- * (in which case, an "identity" value is returned)
- */
-
-/*
- * Evaluate a "null" _value_ dependent on the evaluation context
- */
-static double evaluateNullUnit(double value, double thisCM,
- int nullLayoutMode, int nullArithmeticMode) {
- double result = value;
- if (!nullLayoutMode)
- switch (nullArithmeticMode) {
- case L_plain:
- case L_adding:
- case L_subtracting:
- case L_summing:
- result = 0;
- break;
- case L_multiplying:
- result = 0;
- break;
- case L_maximising:
- result = 0;
- break;
- case L_minimising:
- result = thisCM;
- break;
- }
- return result;
-}
-
-/*
- * Evaluate a "null" _unit_
- * This is used by layout code to get a single "null" _value_
- * from a pureNullUnit (which may be a unitList or a unitArithmetic)
- *
- * This must ONLY be called on a unit which has passed the
- * pureNullUnit test below.
- */
-double pureNullUnitValue(SEXP unit, int index)
-{
- double result = 0;
- if (isUnitArithmetic(unit)) {
- int i;
- if (addOp(unit)) {
- result = pureNullUnitValue(arg1(unit), index) +
- pureNullUnitValue(arg2(unit), index);
- }
- else if (minusOp(unit)) {
- result = pureNullUnitValue(arg1(unit), index) -
- pureNullUnitValue(arg2(unit), index);
- }
- else if (timesOp(unit)) {
- result = REAL(arg1(unit))[index] *
- pureNullUnitValue(arg2(unit), index);
- }
- else if (minFunc(unit)) {
- int n = unitLength(arg1(unit));
- double temp = DBL_MAX;
- result = pureNullUnitValue(arg1(unit), 0);
- for (i=1; i<n; i++) {
- temp = pureNullUnitValue(arg1(unit), i);
- if (temp < result)
- result = temp;
- }
- }
- else if (maxFunc(unit)) {
- int n = unitLength(arg1(unit));
- double temp = DBL_MIN;
- result = pureNullUnitValue(arg1(unit), 0);
- for (i=1; i<n; i++) {
- temp = pureNullUnitValue(arg1(unit), i);
- if (temp > result)
- result = temp;
- }
- }
- else if (sumFunc(unit)) {
- int n = unitLength(arg1(unit));
- result = 0.0;
- for (i=0; i<n; i++) {
- result += pureNullUnitValue(arg1(unit), i);
- }
- }
- else
- error(_("unimplemented unit function"));
- } else if (isUnitList(unit)) {
- /*
- * Recycle if necessary; it is up to the calling code
- * to limit indices to unit length if desired
- */
- int n = unitLength(unit);
- result = pureNullUnitValue(VECTOR_ELT(unit, index % n), 0);
- } else
- result = unitValue(unit, index);
- return result;
-}
-
-int pureNullUnitArithmetic(SEXP unit, int index, pGEDevDesc dd);
-
-int pureNullUnit(SEXP unit, int index, pGEDevDesc dd) {
- int result;
- if (isUnitArithmetic(unit))
- result = pureNullUnitArithmetic(unit, index, dd);
- else if (isUnitList(unit)) {
- /*
- * Recycle if necessary; it is up to the calling code
- * to limit indices to unit length if desired
- */
- int n = unitLength(unit);
- result = pureNullUnit(VECTOR_ELT(unit, index % n), 0, dd);
- } else { /* Just a plain unit */
- /* Special case: if "grobwidth" or "grobheight" unit
- * and width/height(grob) is pure null
- */
- if (unitUnit(unit, index) == L_GROBWIDTH) {
- SEXP grob, updatedgrob, width;
- SEXP widthPreFn, widthFn, widthPostFn, findGrobFn;
- SEXP R_fcall0, R_fcall1, R_fcall2, R_fcall3;
- SEXP savedgpar, savedgrob;
- /*
- * The data could be a gPath to a grob
- * In this case, need to find the grob first, and in order
- * to do that correctly, need to call pre/postDraw code
- */
- PROTECT(grob = unitData(unit, index));
- PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
- PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
- PROTECT(widthPreFn = findFun(install("preDraw"),
- R_gridEvalEnv));
- PROTECT(widthFn = findFun(install("width"), R_gridEvalEnv));
- PROTECT(widthPostFn = findFun(install("postDraw"),
- R_gridEvalEnv));
- if (inherits(grob, "gPath")) {
- if (isNull(savedgrob)) {
- PROTECT(findGrobFn = findFun(install("findGrobinDL"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang2(findGrobFn,
- getListElement(grob, "name")));
- grob = eval(R_fcall0, R_gridEvalEnv);
- } else {
- PROTECT(findGrobFn =findFun(install("findGrobinChildren"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang3(findGrobFn,
- getListElement(grob, "name"),
- getListElement(savedgrob,
- "children")));
- grob = eval(R_fcall0, R_gridEvalEnv);
- }
- UNPROTECT(2);
- }
- PROTECT(R_fcall1 = lang2(widthPreFn, grob));
- PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
- PROTECT(R_fcall2 = lang2(widthFn, updatedgrob));
- PROTECT(width = eval(R_fcall2, R_gridEvalEnv));
- result = pureNullUnit(width, 0, dd);
- PROTECT(R_fcall3 = lang2(widthPostFn, updatedgrob));
- eval(R_fcall3, R_gridEvalEnv);
- setGridStateElement(dd, GSS_GPAR, savedgpar);
- setGridStateElement(dd, GSS_CURRGROB, savedgrob);
- UNPROTECT(11);
- } else if (unitUnit(unit, index) == L_GROBHEIGHT) {
- SEXP grob, updatedgrob, height;
- SEXP heightPreFn, heightFn, heightPostFn, findGrobFn;
- SEXP R_fcall0, R_fcall1, R_fcall2, R_fcall3;
- SEXP savedgpar, savedgrob;
- /*
- * The data could be a gPath to a grob
- * In this case, need to find the grob first, and in order
- * to do that correctly, need to call pre/postDraw code
- */
- PROTECT(grob = unitData(unit, index));
- PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
- PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
- PROTECT(heightPreFn = findFun(install("preDraw"),
- R_gridEvalEnv));
- PROTECT(heightFn = findFun(install("height"), R_gridEvalEnv));
- PROTECT(heightPostFn = findFun(install("postDraw"),
- R_gridEvalEnv));
- if (inherits(grob, "gPath")) {
- if (isNull(savedgrob)) {
- PROTECT(findGrobFn = findFun(install("findGrobinDL"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang2(findGrobFn,
- getListElement(grob, "name")));
- grob = eval(R_fcall0, R_gridEvalEnv);
- } else {
- PROTECT(findGrobFn =findFun(install("findGrobinChildren"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang3(findGrobFn,
- getListElement(grob, "name"),
- getListElement(savedgrob,
- "children")));
- grob = eval(R_fcall0, R_gridEvalEnv);
- }
- UNPROTECT(2);
- }
- PROTECT(R_fcall1 = lang2(heightPreFn, grob));
- PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
- PROTECT(R_fcall2 = lang2(heightFn, updatedgrob));
- PROTECT(height = eval(R_fcall2, R_gridEvalEnv));
- result = pureNullUnit(height, 0, dd);
- PROTECT(R_fcall3 = lang2(heightPostFn, updatedgrob));
- eval(R_fcall3, R_gridEvalEnv);
- setGridStateElement(dd, GSS_GPAR, savedgpar);
- setGridStateElement(dd, GSS_CURRGROB, savedgrob);
- UNPROTECT(11);
- } else
- result = unitUnit(unit, index) == L_NULL;
- }
- return result;
-}
-
-int pureNullUnitArithmetic(SEXP unit, int index, pGEDevDesc dd) {
- /*
- * Initialised to shut up compiler
- */
- int result = 0;
- if (addOp(unit) || minusOp(unit)) {
- result = pureNullUnit(arg1(unit), index, dd) &&
- pureNullUnit(arg2(unit), index, dd);
- }
- else if (timesOp(unit)) {
- result = pureNullUnit(arg2(unit), index, dd);
- }
- else if (minFunc(unit) || maxFunc(unit) || sumFunc(unit)) {
- int n = unitLength(arg1(unit));
- int i = 0;
- result = 1;
- while (result && i<n) {
- result = result && pureNullUnit(arg1(unit), i, dd);
- i += 1;
- }
- }
- else
- error(_("unimplemented unit function"));
- return result;
-}
-
-/**************************
- * Code for handling "grobwidth" units
- **************************
- */
-
-/* NOTE: this code calls back to R code to perform
- * set.gpar operations, which will impact on grid state variables
- * BUT that's ok(ish) because we save and restore the relevant state
- * variables in here so that the overall effect is NULL.
- *
- * FIXME: OTOH, the calls back to R Code may also perform
- * viewport operations. Again, we restore state as much as possible,
- * but this can "pollute" the viewport tree in some cases.
- */
-
-double evaluateGrobUnit(double value, SEXP grob,
- double vpwidthCM, double vpheightCM,
- int nullLMode, int nullAMode,
- /*
- * Evaluation type
- * 0 = x, 1 = y, 2 = width, 3 = height
- */
- int evalType,
- pGEDevDesc dd)
-{
- double vpWidthCM, vpHeightCM;
- double rotationAngle;
- LViewportContext vpc;
- R_GE_gcontext gc;
- LTransform transform, savedTransform;
- SEXP currentvp, currentgp;
- SEXP preFn, postFn, findGrobFn;
- SEXP evalFnx = R_NilValue, evalFny = R_NilValue;
- SEXP R_fcall0, R_fcall1, R_fcall2x, R_fcall2y, R_fcall3;
- SEXP savedgpar, savedgrob, updatedgrob;
- SEXP unitx = R_NilValue, unity = R_NilValue;
- double result = 0.0;
- Rboolean protectedGrob = FALSE;
- /*
- * We are just doing calculations, not drawing, so
- * we don't want anything recorded on the graphics engine DL
- *
- * FIXME: This should probably be done via a GraphicsEngine.h
- * function call rather than directly playing with dd->recordGraphics
- */
- Rboolean record = dd->recordGraphics;
- dd->recordGraphics = FALSE;
- /*
- * Save the current viewport transform
- * (use to convert location relative to current viewport)
- */
- currentvp = gridStateElement(dd, GSS_VP);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- savedTransform, &rotationAngle);
- /*
- * Save the current gpar state and restore it at the end
- */
- PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
- /*
- * Save the current grob and restore it at the end
- */
- PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
- /*
- * Set up for calling R functions
- */
- PROTECT(preFn = findFun(install("preDraw"), R_gridEvalEnv));
- switch(evalType) {
- case 0:
- case 1:
- PROTECT(evalFnx = findFun(install("xDetails"), R_gridEvalEnv));
- PROTECT(evalFny = findFun(install("yDetails"), R_gridEvalEnv));
- break;
- case 2:
- PROTECT(evalFnx = findFun(install("width"), R_gridEvalEnv));
- break;
- case 3:
- PROTECT(evalFny = findFun(install("height"), R_gridEvalEnv));
- break;
- case 4:
- PROTECT(evalFny = findFun(install("ascentDetails"), R_gridEvalEnv));
- break;
- case 5:
- PROTECT(evalFny = findFun(install("descentDetails"), R_gridEvalEnv));
- break;
- }
- PROTECT(postFn = findFun(install("postDraw"), R_gridEvalEnv));
- /*
- * If grob is actually a gPath, use it to find an actual grob
- */
- if (inherits(grob, "gPath")) {
- /*
- * If the current grob is NULL then we are at the top level
- * and we search the display list, otherwise we search the
- * children of the current grob
- *
- * NOTE: assume here that only gPath of depth == 1 are valid
- */
- if (isNull(savedgrob)) {
- PROTECT(findGrobFn = findFun(install("findGrobinDL"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang2(findGrobFn,
- getListElement(grob, "name")));
- PROTECT(grob = eval(R_fcall0, R_gridEvalEnv));
- } else {
- PROTECT(findGrobFn = findFun(install("findGrobinChildren"),
- R_gridEvalEnv));
- PROTECT(R_fcall0 = lang3(findGrobFn,
- getListElement(grob, "name"),
- getListElement(savedgrob, "children")));
- PROTECT(grob = eval(R_fcall0, R_gridEvalEnv));
- }
- /*
- * Flag to make sure we UNPROTECT these at the end
- */
- protectedGrob = TRUE;
- }
- /* Call preDraw(grob)
- */
- PROTECT(R_fcall1 = lang2(preFn, grob));
- PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
- /*
- * The call to preDraw may have pushed viewports and/or
- * enforced gpar settings, SO we need to re-establish the
- * current viewport and gpar settings before evaluating the
- * width unit.
- *
- * NOTE: we are really relying on the grid state to be coherent
- * when we do stuff like this (i.e., not to have changed since
- * we started evaluating the unit [other than the changes we may
- * have deliberately made above by calling preDraw]). In other
- * words we are relying on no other drawing occurring at the
- * same time as we are doing this evaluation. In other other
- * words, we are relying on there being only ONE process
- * (i.e., NOT multi-threaded).
- */
- currentvp = gridStateElement(dd, GSS_VP);
- currentgp = gridStateElement(dd, GSS_GPAR);
- getViewportTransform(currentvp, dd,
- &vpWidthCM, &vpHeightCM,
- transform, &rotationAngle);
- fillViewportContextFromViewport(currentvp, &vpc);
- /* Call whatever(grob)
- * to get the unit representing the x/y/width/height
- */
- switch (evalType) {
- case 0:
- case 1:
- /*
- * When evaluating grobX/grobY, the value of the unit
- * is an angle that gets passed to xDetails/yDetails
- */
- {
- SEXP val;
- PROTECT(val = ScalarReal(value));
- PROTECT(R_fcall2x = lang3(evalFnx, updatedgrob, val));
- PROTECT(unitx = eval(R_fcall2x, R_gridEvalEnv));
- PROTECT(R_fcall2y = lang3(evalFny, updatedgrob, val));
- PROTECT(unity = eval(R_fcall2y, R_gridEvalEnv));
- }
- break;
- case 2:
- PROTECT(R_fcall2x = lang2(evalFnx, updatedgrob));
- PROTECT(unitx = eval(R_fcall2x, R_gridEvalEnv));
- break;
- case 3:
- case 4:
- case 5:
- PROTECT(R_fcall2y = lang2(evalFny, updatedgrob));
- PROTECT(unity = eval(R_fcall2y, R_gridEvalEnv));
- break;
- }
- /*
- * Transform the unit
- * NOTE: We transform into INCHES so can produce final answer in terms
- * of NPC for original context
- */
- /* Special case for "null" units
- */
- gcontextFromgpar(currentgp, 0, &gc, dd);
- switch(evalType) {
- case 0:
- case 1:
- if (evalType && pureNullUnit(unity, 0, dd)) {
- result = evaluateNullUnit(pureNullUnitValue(unity, 0),
- vpWidthCM,
- nullLMode, nullAMode);
- } else if (pureNullUnit(unitx, 0, dd)) {
- result = evaluateNullUnit(pureNullUnitValue(unitx, 0),
- vpWidthCM,
- nullLMode, nullAMode);
- } else {
- /*
- * Transform to device (to allow for viewports in grob)
- * then adjust relative to current viewport.
- */
- double xx, yy;
- LLocation lin, lout;
- LTransform invt;
- invTransform(savedTransform, invt);
- transformLocn(unitx, unity, 0,
- vpc, &gc,
- vpWidthCM, vpHeightCM, dd,
- transform, &xx, &yy);
- location(xx, yy, lin);
- trans(lin, invt, lout);
- xx = locationX(lout);
- yy = locationY(lout);
- if (evalType)
- result = yy;
- else
- result = xx;
- }
- break;
- case 2:
- if (pureNullUnit(unitx, 0, dd)) {
- result = evaluateNullUnit(pureNullUnitValue(unitx, 0),
- vpWidthCM,
- nullLMode, nullAMode);
- } else {
- result = transformWidthtoINCHES(unitx, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- case 3:
- case 4:
- case 5:
- if (pureNullUnit(unity, 0, dd)) {
- result = evaluateNullUnit(pureNullUnitValue(unity, 0),
- vpWidthCM,
- nullLMode, nullAMode);
- } else {
- result = transformHeighttoINCHES(unity, 0, vpc, &gc,
- vpWidthCM, vpHeightCM,
- dd);
- }
- break;
- }
- /* Call postDraw(grob)
- */
- PROTECT(R_fcall3 = lang2(postFn, updatedgrob));
- eval(R_fcall3, R_gridEvalEnv);
- /*
- * Restore the saved gpar state and grob
- */
- setGridStateElement(dd, GSS_GPAR, savedgpar);
- setGridStateElement(dd, GSS_CURRGROB, savedgrob);
- if (protectedGrob)
- UNPROTECT(3);
- switch(evalType) {
- case 0:
- case 1:
- UNPROTECT(14);
- break;
- case 2:
- case 3:
- case 4:
- case 5:
- UNPROTECT(10);
- }
- /* Return the transformed width
- */
- /*
- * If there is an error or user-interrupt in the above
- * evaluation, dd->recordGraphics is set to TRUE
- * on all graphics devices (see GEonExit(); called in errors.c)
- */
- dd->recordGraphics = record;
- return result;
-}
-
-double evaluateGrobXUnit(double value, SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(value, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 0, dd);
-}
-
-double evaluateGrobYUnit(double value, SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(value, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 1, dd);
-}
-
-double evaluateGrobWidthUnit(SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 2, dd);
-}
-
-double evaluateGrobHeightUnit(SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 3, dd);
-}
-
-double evaluateGrobAscentUnit(SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 4, dd);
-}
-
-double evaluateGrobDescentUnit(SEXP grob,
- double vpheightCM, double vpwidthCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
- nullLMode, nullAMode, 5, dd);
-}
-
-/**************************
- * TRANSFORMATIONS
- **************************
- */
-
-/* Map a value from arbitrary units to INCHES */
-
-/*
- * NULL units are a special case
- * If L_nullLayoutMode = 1 then the value returned is a NULL unit value
- * Otherwise it is an INCHES value
- */
-double transform(double value, int unit, SEXP data,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double asc, dsc, wid;
- double result = value;
- switch (unit) {
- case L_NPC:
- result = (result * thisCM)/2.54; /* 2.54 cm per inch */
- break;
- case L_CM:
- result = result/2.54;
- break;
- case L_INCHES:
- break;
- /* FIXME: The following two assume that the pointsize specified
- * by the user is actually the pointsize provided by the
- * device. This is NOT a safe assumption
- * One possibility would be to do a call to GReset(), just so
- * that mapping() gets called, just so that things like
- * xNDCPerLine are up-to-date, THEN call GStrHeight("M")
- * or somesuch.
- */
- case L_CHAR:
- case L_MYCHAR: /* FIXME: Remove this when I can */
- result = (result * gc->ps * gc->cex)/72; /* 72 points per inch */
- break;
- case L_LINES:
- case L_MYLINES: /* FIXME: Remove this when I can */
- result = (result * gc->ps * gc->cex * gc->lineheight)/72;
- break;
- case L_SNPC:
- if (thisCM <= otherCM)
- result = (result * thisCM)/2.54;
- else
- result = (result * otherCM)/2.54;
- break;
- case L_MM:
- result = (result/10)/2.54;
- break;
- /* Maybe an opportunity for some constants below here (!)
- */
- case L_POINTS:
- result = result/72.27;
- break;
- case L_PICAS:
- result = (result*12)/72.27;
- break;
- case L_BIGPOINTS:
- result = result/72;
- break;
- case L_DIDA:
- result = result/1157*1238/72.27;
- break;
- case L_CICERO:
- result = result*12/1157*1238/72.27;
- break;
- case L_SCALEDPOINTS:
- result = result/65536/72.27;
- break;
- case L_STRINGWIDTH:
- case L_MYSTRINGWIDTH: /* FIXME: Remove this when I can */
- if (isExpression(data))
- result = result*
- fromDeviceWidth(GEExpressionWidth(VECTOR_ELT(data, 0), gc, dd),
- GE_INCHES, dd);
- else
- result = result*
- fromDeviceWidth(GEStrWidth(CHAR(STRING_ELT(data, 0)),
- getCharCE(STRING_ELT(data, 0)),
- gc, dd),
- GE_INCHES, dd);
- break;
- case L_STRINGHEIGHT:
- case L_MYSTRINGHEIGHT: /* FIXME: Remove this when I can */
- if (isExpression(data))
- result = result*
- fromDeviceHeight(GEExpressionHeight(VECTOR_ELT(data, 0),
- gc, dd),
- GE_INCHES, dd);
- else
- /* FIXME: what encoding is this? */
- result = result*
- fromDeviceHeight(GEStrHeight(CHAR(STRING_ELT(data, 0)), -1,
- gc, dd),
- GE_INCHES, dd);
- break;
- case L_STRINGASCENT:
- if (isExpression(data))
- GEExpressionMetric(VECTOR_ELT(data, 0), gc,
- &asc, &dsc, &wid,
- dd);
- else
- GEStrMetric(CHAR(STRING_ELT(data, 0)),
- getCharCE(STRING_ELT(data, 0)), gc,
- &asc, &dsc, &wid,
- dd);
- result = result*fromDeviceHeight(asc, GE_INCHES, dd);
- break;
- case L_STRINGDESCENT:
- if (isExpression(data))
- GEExpressionMetric(VECTOR_ELT(data, 0), gc,
- &asc, &dsc, &wid,
- dd);
- else
- GEStrMetric(CHAR(STRING_ELT(data, 0)),
- getCharCE(STRING_ELT(data, 0)), gc,
- &asc, &dsc, &wid,
- dd);
- result = result*fromDeviceHeight(dsc, GE_INCHES, dd);
- break;
- case L_GROBX:
- result = evaluateGrobXUnit(value, data, thisCM, otherCM,
- nullLMode, nullAMode, dd);
- break;
- case L_GROBY:
- result = evaluateGrobYUnit(value, data, otherCM, thisCM,
- nullLMode, nullAMode, dd);
- break;
- case L_GROBWIDTH:
- result = value*evaluateGrobWidthUnit(data, thisCM, otherCM,
- nullLMode, nullAMode, dd);
- break;
- case L_GROBHEIGHT:
- result = value*evaluateGrobHeightUnit(data, otherCM, thisCM,
- nullLMode, nullAMode, dd);
- break;
- case L_GROBASCENT:
- result = value*evaluateGrobAscentUnit(data, otherCM, thisCM,
- nullLMode, nullAMode, dd);
- break;
- case L_GROBDESCENT:
- result = value*evaluateGrobDescentUnit(data, otherCM, thisCM,
- nullLMode, nullAMode, dd);
- break;
- case L_NULL:
- result = evaluateNullUnit(result, thisCM, nullLMode, nullAMode);
- break;
- default:
- error(_("invalid unit or unit not yet implemented"));
- }
- /*
- * For physical units, scale the result by GSS_SCALE (a "zoom" factor)
- */
- switch (unit) {
- case L_INCHES:
- case L_CM:
- case L_MM:
- case L_POINTS:
- case L_PICAS:
- case L_BIGPOINTS:
- case L_DIDA:
- case L_CICERO:
- case L_SCALEDPOINTS:
- result = result * REAL(gridStateElement(dd, GSS_SCALE))[0];
- break;
- default:
- /*
- * No need to scale relative coordinates (NPC, NATIVE, NULL)
- * CHAR and LINES already scaled because of scaling in gcontextFromGPar()
- * Ditto STRINGWIDTH/HEIGHT
- * GROBWIDTH/HEIGHT recurse into here so scaling already done
- */
- break;
- }
- return result;
-}
-
-/* FIXME: scales are only linear at the moment */
-double transformLocation(double location, int unit, SEXP data,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double result = location;
- switch (unit) {
- case L_NATIVE:
- /* It is invalid to create a viewport with identical limits on scale
- * so we are protected from divide-by-zero
- */
- result = ((result - scalemin)/(scalemax - scalemin))*thisCM/2.54;
- break;
- default:
- result = transform(location, unit, data, scalemin, scalemax,
- gc, thisCM, otherCM, nullLMode, nullAMode, dd);
- }
- return result;
-}
-
-double transformXArithmetic(SEXP x, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd);
-
-double transformX(SEXP x, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double result;
- int unit;
- SEXP data;
- if (isUnitArithmetic(x))
- result = transformXArithmetic(x, index, vpc, gc,
- widthCM, heightCM, nullLMode, dd);
- else if (isUnitList(x)) {
- int n = unitLength(x);
- result = transformX(VECTOR_ELT(x, index % n), 0, vpc, gc,
- widthCM, heightCM, nullLMode, nullAMode, dd);
- } else { /* Just a plain unit */
- int nullamode;
- if (nullAMode == 0)
- nullamode = L_plain;
- else
- nullamode = nullAMode;
- result = unitValue(x, index);
- unit = unitUnit(x, index);
- PROTECT(data = unitData(x, index));
- result = transformLocation(result, unit, data,
- vpc.xscalemin, vpc.xscalemax, gc,
- widthCM, heightCM,
- nullLMode,
- nullamode,
- dd);
- UNPROTECT(1);
- }
- return result;
-}
-
-double transformYArithmetic(SEXP y, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd);
-
-double transformY(SEXP y, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double result;
- int unit;
- SEXP data;
- if (isUnitArithmetic(y))
- result = transformYArithmetic(y, index, vpc, gc,
- widthCM, heightCM, nullLMode, dd);
- else if (isUnitList(y)) {
- int n = unitLength(y);
- result = transformY(VECTOR_ELT(y, index % n), 0, vpc, gc,
- widthCM, heightCM, nullLMode, nullAMode, dd);
- } else { /* Just a unit object */
- int nullamode;
- if (nullAMode == 0)
- nullamode = L_plain;
- else
- nullamode = nullAMode;
- result = unitValue(y, index);
- unit = unitUnit(y, index);
- PROTECT(data = unitData(y, index));
- result = transformLocation(result, unit, data,
- vpc.yscalemin, vpc.yscalemax, gc,
- heightCM, widthCM,
- nullLMode,
- nullamode,
- dd);
- UNPROTECT(1);
- }
- return result;
-}
-
-double transformDimension(double dim, int unit, SEXP data,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- int nullLMode, int nullAMode,
- pGEDevDesc dd)
-{
- double result = dim;
- switch (unit) {
- case L_NATIVE:
- /* It is invalid to create a viewport with identical limits on scale
- * so we are protected from divide-by-zero
- */
- result = ((dim)/(scalemax - scalemin))*thisCM/2.54;
- break;
- default:
- result = transform(dim, unit, data, scalemin, scalemax, gc,
- thisCM, otherCM, nullLMode, nullAMode, dd);
- }
- return result;
-}
-
-double transformWidthArithmetic(SEXP width, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd);
-
-double transformWidth(SEXP width, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double result;
- int unit;
- SEXP data;
- if (isUnitArithmetic(width))
- result = transformWidthArithmetic(width, index, vpc, gc,
- widthCM, heightCM, nullLMode, dd);
- else if (isUnitList(width)) {
- int n = unitLength(width);
- result = transformWidth(VECTOR_ELT(width, index % n), 0, vpc, gc,
- widthCM, heightCM, nullLMode, nullAMode, dd);
- } else { /* Just a unit object */
- int nullamode;
- if (nullAMode == 0)
- nullamode = L_plain;
- else
- nullamode = nullAMode;
- result = unitValue(width, index);
- unit = unitUnit(width, index);
- PROTECT(data = unitData(width, index));
- result = transformDimension(result, unit, data,
- vpc.xscalemin, vpc.xscalemax, gc,
- widthCM, heightCM,
- nullLMode,
- nullamode,
- dd);
- UNPROTECT(1);
- }
- return result;
-}
-
-double transformHeightArithmetic(SEXP height, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd);
-
-double transformHeight(SEXP height, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, int nullAMode, pGEDevDesc dd)
-{
- double result;
- int unit;
- SEXP data;
- if (isUnitArithmetic(height))
- result = transformHeightArithmetic(height, index, vpc, gc,
- widthCM, heightCM, nullLMode, dd);
- else if (isUnitList(height)) {
- int n = unitLength(height);
- result = transformHeight(VECTOR_ELT(height, index % n), 0, vpc, gc,
- widthCM, heightCM, nullLMode, nullAMode, dd);
- } else { /* Just a unit object */
- int nullamode;
- if (nullAMode == 0)
- nullamode = L_plain;
- else
- nullamode = nullAMode;
- result = unitValue(height, index);
- unit = unitUnit(height, index);
- PROTECT(data = unitData(height, index));
- result = transformDimension(result, unit, data,
- vpc.yscalemin, vpc.yscalemax, gc,
- heightCM, widthCM,
- nullLMode,
- nullamode,
- dd);
- UNPROTECT(1);
- }
- return result;
-}
-
-double transformXArithmetic(SEXP x, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd)
-{
- int i;
- double result = 0;
- if (addOp(x)) {
- result = transformX(arg1(x), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd) +
- transformX(arg2(x), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd);
- }
- else if (minusOp(x)) {
- result = transformX(arg1(x), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd) -
- transformX(arg2(x), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd);
- }
- else if (timesOp(x)) {
- result = REAL(arg1(x))[index % LENGTH(arg1(x))] *
- transformX(arg2(x), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_multiplying, dd);
- }
- else if (minFunc(x)) {
- int n = unitLength(arg1(x));
- double temp = DBL_MAX;
- result = transformX(arg1(x), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformX(arg1(x), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- if (temp < result)
- result = temp;
- }
- }
- else if (maxFunc(x)) {
- int n = unitLength(arg1(x));
- double temp = DBL_MIN;
- result = transformX(arg1(x), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformX(arg1(x), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- if (temp > result)
- result = temp;
- }
- }
- else if (sumFunc(x)) {
- int n = unitLength(arg1(x));
- result = 0.0;
- for (i=0; i<n; i++) {
- result += transformX(arg1(x), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_summing, dd);
- }
- }
- else
- error(_("unimplemented unit function"));
- return result;
-}
-
-double transformYArithmetic(SEXP y, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd)
-{
- int i;
- double result = 0;
- if (addOp(y)) {
- result = transformY(arg1(y), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd) +
- transformY(arg2(y), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd);
- }
- else if (minusOp(y)) {
- result = transformY(arg1(y), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd) -
- transformY(arg2(y), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd);
- }
- else if (timesOp(y)) {
- result = REAL(arg1(y))[index % LENGTH(arg1(y))] *
- transformY(arg2(y), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_multiplying, dd);
- }
- else if (minFunc(y)) {
- int n = unitLength(arg1(y));
- double temp = DBL_MAX;
- result = transformY(arg1(y), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformY(arg1(y), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- if (temp < result)
- result = temp;
- }
- }
- else if (maxFunc(y)) {
- int n = unitLength(arg1(y));
- double temp = DBL_MIN;
- result = transformY(arg1(y), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformY(arg1(y), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- if (temp > result)
- result = temp;
- }
- }
- else if (sumFunc(y)) {
- int n = unitLength(arg1(y));
- result = 0.0;
- for (i=0; i<n; i++) {
- result += transformY(arg1(y), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_summing, dd);
- }
- }
- else
- error(_("unimplemented unit function"));
- return result;
-}
-
-double transformWidthArithmetic(SEXP width, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd)
-{
- int i;
- double result = 0;
- if (addOp(width)) {
- result = transformWidth(arg1(width), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd) +
- transformWidth(arg2(width), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd);
- }
- else if (minusOp(width)) {
- result = transformWidth(arg1(width), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd) -
- transformWidth(arg2(width), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd);
- }
- else if (timesOp(width)) {
- result = REAL(arg1(width))[index % LENGTH(arg1(width))] *
- transformWidth(arg2(width), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_multiplying, dd);
- }
- else if (minFunc(width)) {
- int n = unitLength(arg1(width));
- double temp = DBL_MAX;
- result = transformWidth(arg1(width), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformWidth(arg1(width), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- if (temp < result)
- result = temp;
- }
- }
- else if (maxFunc(width)) {
- int n = unitLength(arg1(width));
- double temp = DBL_MIN;
- result = transformWidth(arg1(width), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformWidth(arg1(width), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- if (temp > result)
- result = temp;
- }
- }
- else if (sumFunc(width)) {
- int n = unitLength(arg1(width));
- result = 0.0;
- for (i=0; i<n; i++) {
- result += transformWidth(arg1(width), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_summing, dd);
- }
- }
- else
- error(_("unimplemented unit function"));
- return result;
-}
-
-double transformHeightArithmetic(SEXP height, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- int nullLMode, pGEDevDesc dd)
-{
- int i;
- double result = 0;
- if (addOp(height)) {
- result = transformHeight(arg1(height), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd) +
- transformHeight(arg2(height), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_adding,
- dd);
- }
- else if (minusOp(height)) {
- result = transformHeight(arg1(height), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd) -
- transformHeight(arg2(height), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_subtracting,
- dd);
- }
- else if (timesOp(height)) {
- result = REAL(arg1(height))[index % LENGTH(arg1(height))] *
- transformHeight(arg2(height), index, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_multiplying, dd);
- }
- else if (minFunc(height)) {
- int n = unitLength(arg1(height));
- double temp = DBL_MAX;
- result = transformHeight(arg1(height), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformHeight(arg1(height), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_minimising,
- dd);
- if (temp < result)
- result = temp;
- }
- }
- else if (maxFunc(height)) {
- int n = unitLength(arg1(height));
- double temp = DBL_MIN;
- result = transformHeight(arg1(height), 0, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- for (i=1; i<n; i++) {
- temp = transformHeight(arg1(height), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_maximising,
- dd);
- if (temp > result)
- result = temp;
- }
- }
- else if (sumFunc(height)) {
- int n = unitLength(arg1(height));
- result = 0.0;
- for (i=0; i<n; i++) {
- result += transformHeight(arg1(height), i, vpc, gc,
- widthCM, heightCM,
- nullLMode, L_summing, dd);
- }
- }
- else
- error(_("unimplemented unit function"));
- return result;
-}
-
-/* Code for transforming a location in INCHES using a transformation matrix.
- * We work in INCHES so that rotations can be incorporated within the
- * transformation matrix (i.e., the units are the same in both x- and
- * y-directions).
- * INCHES rather than CM because the R graphics engine only has INCHES.
- */
-
-/* The original transform[X | Y | Width | Height] functions
- * were written to transform to NPC. Rather than muck with them,
- * I am just wrappering them to get the new transformation to INCHES
- * In other words, the reason for the apparent inefficiency here
- * is historical.
- */
-
-/* It is even more inefficient-looking now because I ended up mucking
- * with transform() to return INCHES (to fix bug if width/heightCM == 0)
- * and by then there was too much code that called transformXtoINCHES
- * to be bothered changing calls to it
- */
-
-/* The difference between transform*toINCHES and transformLocn/Dimn
- * is that the former are just converting from one coordinate system
- * to INCHES; the latter are converting from INCHES relative to
- * the parent to INCHES relative to the device.
- */
-double transformXtoINCHES(SEXP x, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd)
-{
- return transformX(x, index, vpc, gc,
- widthCM, heightCM, 0, 0, dd);
-}
-
-double transformYtoINCHES(SEXP y, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd)
-{
- return transformY(y, index, vpc, gc,
- widthCM, heightCM, 0, 0, dd);
-}
-
-void transformLocn(SEXP x, SEXP y, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd,
- LTransform t,
- double *xx, double *yy)
-{
- LLocation lin, lout;
- /* x and y are unit objects (i.e., values in any old coordinate
- * system) so the first step is to convert them both to CM
- */
- *xx = transformXtoINCHES(x, index, vpc, gc,
- widthCM, heightCM, dd);
- *yy = transformYtoINCHES(y, index, vpc, gc,
- widthCM, heightCM, dd);
- location(*xx, *yy, lin);
- trans(lin, t, lout);
- *xx = locationX(lout);
- *yy = locationY(lout);
-}
-
-double transformWidthtoINCHES(SEXP w, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd)
-{
- return transformWidth(w, index, vpc, gc,
- widthCM, heightCM, 0, 0, dd);
-}
-
-double transformHeighttoINCHES(SEXP h, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd)
-{
- return transformHeight(h, index, vpc, gc,
- widthCM, heightCM, 0, 0, dd);
-}
-
-void transformDimn(SEXP w, SEXP h, int index,
- LViewportContext vpc,
- const pGEcontext gc,
- double widthCM, double heightCM,
- pGEDevDesc dd,
- double rotationAngle,
- double *ww, double *hh)
-{
- LLocation din, dout;
- LTransform r;
- *ww = transformWidthtoINCHES(w, index, vpc, gc,
- widthCM, heightCM, dd);
- *hh = transformHeighttoINCHES(h, index, vpc, gc,
- widthCM, heightCM, dd);
- location(*ww, *hh, din);
- rotation(rotationAngle, r);
- trans(din, r, dout);
- *ww = locationX(dout);
- *hh = locationY(dout);
-}
-
-/*
- * ****************************
- * Inverse Transformations
- * ****************************
- */
-
-/*
- * Take a value in inches within the viewport and convert to some
- * other coordinate system
- */
-
-double transformFromINCHES(double value, int unit,
- const pGEcontext gc,
- double thisCM, double otherCM,
- pGEDevDesc dd)
-{
- /*
- * Convert to NPC
- */
- double result = value;
- switch (unit) {
- case L_NPC:
- result = result/(thisCM/2.54);
- break;
- case L_CM:
- result = result*2.54;
- break;
- case L_INCHES:
- break;
- /* FIXME: The following two assume that the pointsize specified
- * by the user is actually the pointsize provided by the
- * device. This is NOT a safe assumption
- * One possibility would be to do a call to GReset(), just so
- * that mapping() gets called, just so that things like
- * xNDCPerLine are up-to-date, THEN call GStrHeight("M")
- * or somesuch.
- */
- case L_CHAR:
- result = (result*72)/(gc->ps*gc->cex);
- break;
- case L_LINES:
- result = (result*72)/(gc->ps*gc->cex*gc->lineheight);
- break;
- case L_MM:
- result = result*2.54*10;
- break;
- /* Maybe an opportunity for some constants below here (!)
- */
- case L_POINTS:
- result = result*72.27;
- break;
- case L_PICAS:
- result = result/12*72.27;
- break;
- case L_BIGPOINTS:
- result = result*72;
- break;
- case L_DIDA:
- result = result/1238*1157*72.27;
- break;
- case L_CICERO:
- result = result/1238*1157*72.27/12;
- break;
- case L_SCALEDPOINTS:
- result = result*65536*72.27;
- break;
- /*
- * I'm not sure the remaining ones makes any sense.
- * For simplicity, these are just forbidden for now.
- */
- case L_SNPC:
- case L_MYCHAR:
- case L_MYLINES:
- case L_STRINGWIDTH:
- case L_MYSTRINGWIDTH:
- case L_STRINGHEIGHT:
- case L_MYSTRINGHEIGHT:
- case L_GROBX:
- case L_GROBY:
- case L_GROBWIDTH:
- case L_GROBHEIGHT:
- case L_NULL:
- default:
- error(_("invalid unit or unit not yet implemented"));
- }
- /*
- * For physical units, reverse the scale by GSS_SCALE (a "zoom" factor)
- */
- switch (unit) {
- case L_INCHES:
- case L_CM:
- case L_MM:
- case L_POINTS:
- case L_PICAS:
- case L_BIGPOINTS:
- case L_DIDA:
- case L_CICERO:
- case L_SCALEDPOINTS:
- result = result / REAL(gridStateElement(dd, GSS_SCALE))[0];
- break;
- default:
- /*
- * No need to scale relative coordinates (NPC, NATIVE, NULL)
- * All other units forbidden anyway
- */
- break;
- }
- return result;
-}
-
-/*
- * This corresponds to transform[X|Y]toINCHES() because
- * it works only within the current viewport, BUT
- * it is much simpler because it is supplied with a
- * double value in INCHES (rather than a unit object in
- * an arbitrary unit).
- *
- * For conceptual symmetry, it should probably return a
- * unit object, but it only returns a double value.
- * The construction of a unit object with the appropriate
- * unit must be performed by the calling function (or higher).
- * This is probably easiest done right up in R code.
- */
-double transformXYFromINCHES(double location, int unit,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- pGEDevDesc dd)
-{
- double result = location;
- /* Special case if "thisCM == 0":
- * If converting FROM relative unit, result will already be zero
- * so leave it there.
- * If converting FROM absolute unit that is zero, ditto.
- * Otherwise (converting FROM non-zero absolute unit),
- * converting to relative unit is an error.
- */
- if ((unit == L_NATIVE || unit == L_NPC) &&
- thisCM < 1e-6) {
- if (result != 0)
- error(_("Viewport has zero dimension(s)"));
- } else {
- switch (unit) {
- case L_NATIVE:
- result = scalemin + (result/(thisCM/2.54))*(scalemax - scalemin);
- break;
- default:
- result = transformFromINCHES(location, unit, gc,
- thisCM, otherCM, dd);
- }
- }
- return result;
-}
-
-double transformWidthHeightFromINCHES(double dimension, int unit,
- double scalemin, double scalemax,
- const pGEcontext gc,
- double thisCM, double otherCM,
- pGEDevDesc dd)
-{
- double result = dimension;
- /* Special case if "thisCM == 0":
- * If converting FROM relative unit, result will already be zero
- * so leave it there.
- * If converting FROM absolute unit that is zero, ditto.
- * Otherwise (converting FROM non-zero absolute unit),
- * converting to relative unit is an error.
- */
- if ((unit == L_NATIVE || unit == L_NPC) &&
- thisCM < 1e-6) {
- if (result != 0)
- error(_("Viewport has zero dimension(s)"));
- } else {
- switch (unit) {
- case L_NATIVE:
- result = (result/(thisCM/2.54))*(scalemax - scalemin);
- break;
- default:
- result = transformFromINCHES(dimension, unit, gc,
- thisCM, otherCM, dd);
- }
- }
- return result;
-}
-
-/*
- * Special case conversion from relative unit to relative unit,
- * only used when relevant widthCM or heightCM is zero, so
- * we cannot transform thru INCHES (or we get divide-by-zero)
- *
- * Protected from divide-by-zero here because viewport with
- * identical scale limits is disallowed.
- */
-double transformXYtoNPC(double x, int from, double min, double max)
-{
- double result = x;
- switch (from) {
- case L_NPC:
- break;
- case L_NATIVE:
- result = (x - min)/(max - min);
- break;
- default:
- error(_("Unsupported unit conversion"));
- }
- return(result);
-}
-
-double transformWHtoNPC(double x, int from, double min, double max)
-{
- double result = x;
- switch (from) {
- case L_NPC:
- break;
- case L_NATIVE:
- result = x/(max - min);
- break;
- default:
- error(_("Unsupported unit conversion"));
- }
- return(result);
-}
-
-double transformXYfromNPC(double x, int to, double min, double max)
-{
- double result = x;
- switch (to) {
- case L_NPC:
- break;
- case L_NATIVE:
- result = min + x*(max - min);
- break;
- default:
- error(_("Unsupported unit conversion"));
- }
- return(result);
-}
-
-double transformWHfromNPC(double x, int to, double min, double max)
-{
- double result = x;
- switch (to) {
- case L_NPC:
- break;
- case L_NATIVE:
- result = x*(max - min);
- break;
- default:
- error(_("Unsupported unit conversion"));
- }
- return(result);
-}
-
-/* Attempt to make validating units faster
- */
-typedef struct {
- char *name;
- int code;
-} UnitTab;
-
-/* NOTE this table must match the order in grid.h
- */
-static UnitTab UnitTable[] = {
- { "npc", 0 },
- { "cm", 1 },
- { "inches", 2 },
- { "lines", 3 },
- { "native", 4 },
- { "null", 5 },
- { "snpc", 6 },
- { "mm", 7 },
- { "points", 8 },
- { "picas", 9 },
- { "bigpts", 10 },
- { "dida", 11 },
- { "cicero", 12 },
- { "scaledpts", 13 },
- { "strwidth", 14 },
- { "strheight", 15 },
- { "strascent", 16 },
- { "strdescent", 17 },
-
- { "char", 18 },
- { "grobx", 19 },
- { "groby", 20 },
- { "grobwidth", 21 },
- { "grobheight", 22 },
- { "grobascent", 23 },
- { "grobdescent", 24 },
-
- { "mylines", 103 },
- { "mychar", 104 },
- { "mystrwidth", 105 },
- { "mystrheight", 106 },
-
- /*
- * Some pseudonyms
- */
- { "centimetre", 1001 },
- { "centimetres", 1001 },
- { "centimeter", 1001 },
- { "centimeters", 1001 },
- { "in", 1002 },
- { "inch", 1002 },
- { "line", 1003 },
- { "millimetre", 1007 },
- { "millimetres", 1007 },
- { "millimeter", 1007 },
- { "millimeters", 1007 },
- { "point", 1008 },
- { "pt", 1008 },
-
- { NULL, -1 }
-};
-
-int convertUnit(SEXP unit, int index)
-{
- int i = 0;
- int result = 0;
- int found = 0;
- while (result >= 0 && !found) {
- if (UnitTable[i].name == NULL)
- result = -1;
- else {
- found = !strcmp(CHAR(STRING_ELT(unit, index)), UnitTable[i].name);
- if (found) {
- result = UnitTable[i].code;
- /* resolve pseudonyms */
- if (result > 1000) {
- result = result - 1000;
- }
- }
- }
- i += 1;
- }
- if (result < 0)
- error(_("Invalid unit"));
- return result;
-}
-
-SEXP validUnits(SEXP units)
-{
- int i;
- int n = LENGTH(units);
- SEXP answer = R_NilValue;
- if (n > 0) {
- if (isString(units)) {
- PROTECT(answer = allocVector(INTSXP, n));
- for (i = 0; i<n; i++)
- INTEGER(answer)[i] = convertUnit(units, i);
- UNPROTECT(1);
- } else {
- error(_("'units' must be character"));
- }
- } else {
- error(_("'units' must be of length > 0"));
- }
- return answer;
-}
-
-
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/util.c b/com.oracle.truffle.r.native/library/grid/src/util.c
deleted file mode 100644
index 3780cb11c9824eea61f87bf416e1f2ec9f6f496a..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/util.c
+++ /dev/null
@@ -1,288 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-8 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/
- */
-
-#include "grid.h"
-#include <string.h>
-
-/* Get the list element named str, or return NULL.
- * Copied from the Writing R Extensions manual (which copied it from nls)
- */
-SEXP getListElement(SEXP list, char *str)
-{
- SEXP elmt = R_NilValue;
- SEXP names = getAttrib(list, R_NamesSymbol);
- int i;
-
- for (i = 0; i < length(list); i++)
- if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
- elmt = VECTOR_ELT(list, i);
- break;
- }
- return elmt;
-}
-
-void setListElement(SEXP list, char *str, SEXP value)
-{
- SEXP names = getAttrib(list, R_NamesSymbol);
- int i;
-
- for (i = 0; i < length(list); i++)
- if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
- SET_VECTOR_ELT(list, i, value);
- break;
- }
-}
-
-/* The lattice R code checks values to make sure that they are numeric
- * BUT we do not know whether the values are integer or real
- * SO we have to be careful when extracting numeric values.
- * This function assumes that x is numeric (obviously).
- */
-double numeric(SEXP x, int index)
-{
- if (isReal(x))
- return REAL(x)[index];
- else if (isInteger(x))
- return INTEGER(x)[index];
- return NA_REAL;
-}
-
-/***********************
- * Stuff for rectangles
- ***********************/
-
-/* Fill a rectangle struct
- */
-void rect(double x1, double x2, double x3, double x4,
- double y1, double y2, double y3, double y4,
- LRect *r)
-{
- r->x1 = x1;
- r->x2 = x2;
- r->x3 = x3;
- r->x4 = x4;
- r->y1 = y1;
- r->y2 = y2;
- r->y3 = y3;
- r->y4 = y4;
-}
-
-void copyRect(LRect r1, LRect *r)
-{
- r->x1 = r1.x1;
- r->x2 = r1.x2;
- r->x3 = r1.x3;
- r->x4 = r1.x4;
- r->y1 = r1.y1;
- r->y2 = r1.y2;
- r->y3 = r1.y3;
- r->y4 = r1.y4;
-}
-
-/* Do two lines intersect ?
- * Algorithm from Paul Bourke
- * (http://www.swin.edu.au/astronomy/pbourke/geometry/lineline2d/index.html)
- */
-int linesIntersect(double x1, double x2, double x3, double x4,
- double y1, double y2, double y3, double y4)
-{
- double result = 0;
- double denom = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1);
- double ua = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
- /* If the lines are parallel ...
- */
- if (denom == 0) {
- /* If the lines are coincident ...
- */
- if (ua == 0) {
- /* If the lines are vertical ...
- */
- if (x1 == x2) {
- /* Compare y-values
- */
- if (!((y1 < y3 && fmax2(y1, y2) < fmin2(y3, y4)) ||
- (y3 < y1 && fmax2(y3, y4) < fmin2(y1, y2))))
- result = 1;
- } else {
- /* Compare x-values
- */
- if (!((x1 < x3 && fmax2(x1, x2) < fmin2(x3, x4)) ||
- (x3 < x1 && fmax2(x3, x4) < fmin2(x1, x2))))
- result = 1;
- }
- }
- }
- /* ... otherwise, calculate where the lines intersect ...
- */
- else {
- double ub = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
- ua = ua/denom;
- ub = ub/denom;
- /* Check for overlap
- */
- if ((ua > 0 && ua < 1) && (ub > 0 && ub < 1))
- result = 1;
- }
- return (int) result;
-}
-
-int edgesIntersect(double x1, double x2, double y1, double y2,
- LRect r)
-{
- int result = 0;
- if (linesIntersect(x1, x2, r.x1, r.x2, y1, y2, r.y1, r.y2) ||
- linesIntersect(x1, x2, r.x2, r.x3, y1, y2, r.y2, r.y3) ||
- linesIntersect(x1, x2, r.x3, r.x4, y1, y2, r.y3, r.y4) ||
- linesIntersect(x1, x2, r.x4, r.x1, y1, y2, r.y4, r.y1))
- result = 1;
- return result;
-}
-
-/* Do two rects intersect ?
- * For each edge in r1, does the edge intersect with any edge in r2 ?
- * FIXME: Should add first check for non-intersection of
- * bounding boxes of rects (?)
- */
-int intersect(LRect r1, LRect r2)
-{
- int result = 0;
- if (edgesIntersect(r1.x1, r1.x2, r1.y1, r1.y2, r2) ||
- edgesIntersect(r1.x2, r1.x3, r1.y2, r1.y3, r2) ||
- edgesIntersect(r1.x3, r1.x4, r1.y3, r1.y4, r2) ||
- edgesIntersect(r1.x4, r1.x1, r1.y4, r1.y1, r2))
- result = 1;
- return result;
-}
-
-/* Calculate the bounding rectangle for a string.
- * x and y assumed to be in INCHES.
- */
-void textRect(double x, double y, SEXP text, int i,
- const pGEcontext gc,
- double xadj, double yadj,
- double rot, pGEDevDesc dd, LRect *r)
-{
- /* NOTE that we must work in inches for the angles to be correct
- */
- LLocation bl, br, tr, tl;
- LLocation tbl, tbr, ttr, ttl;
- LTransform thisLocation, thisRotation, thisJustification;
- LTransform tempTransform, transform;
- double w, h;
- if (isExpression(text)) {
- SEXP expr = VECTOR_ELT(text, i % LENGTH(text));
- w = fromDeviceWidth(GEExpressionWidth(expr, gc, dd),
- GE_INCHES, dd);
- h = fromDeviceHeight(GEExpressionHeight(expr, gc, dd),
- GE_INCHES, dd);
- } else {
- const char* string = CHAR(STRING_ELT(text, i % LENGTH(text)));
- w = fromDeviceWidth(GEStrWidth(string,
- (gc->fontface == 5) ? CE_SYMBOL :
- getCharCE(STRING_ELT(text, i % LENGTH(text))),
- gc, dd),
- GE_INCHES, dd);
- h = fromDeviceHeight(GEStrHeight(string,
- (gc->fontface == 5) ? CE_SYMBOL :
- getCharCE(STRING_ELT(text, i % LENGTH(text))),
- gc, dd),
- GE_INCHES, dd);
- }
- location(0, 0, bl);
- location(w, 0, br);
- location(w, h, tr);
- location(0, h, tl);
- translation(-xadj*w, -yadj*h, thisJustification);
- translation(x, y, thisLocation);
- if (rot != 0)
- rotation(rot, thisRotation);
- else
- identity(thisRotation);
- /* Position relative to origin of rotation THEN rotate.
- */
- multiply(thisJustification, thisRotation, tempTransform);
- /* Translate to (x, y)
- */
- multiply(tempTransform, thisLocation, transform);
- trans(bl, transform, tbl);
- trans(br, transform, tbr);
- trans(tr, transform, ttr);
- trans(tl, transform, ttl);
- rect(locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl),
- locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl),
- r);
- /* For debugging, the following prints out an R statement to draw the
- * bounding box
- */
- /*
- Rprintf("\ngrid.lines(c(%f, %f, %f, %f, %f), c(%f, %f, %f, %f, %f), default.units=\"inches\")\n",
- locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl),
- locationX(tbl),
- locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl),
- locationY(tbl)
- );
- */
-}
-
-/***********************
- * Stuff for making persistent graphical objects
- ***********************/
-
-/* Will have already created an SEXP in R. This just stores the
- * SEXP in an external reference so that I can get multiple
- * references to it.
- */
-SEXP L_CreateSEXPPtr(SEXP s)
-{
- /* Allocate a list of length one on the R heap
- */
- SEXP data, result;
- PROTECT(data = allocVector(VECSXP, 1));
- SET_VECTOR_ELT(data, 0, s);
- result = R_MakeExternalPtr(data, R_NilValue, data);
- UNPROTECT(1);
- return result;
-}
-
-SEXP L_GetSEXPPtr(SEXP sp)
-{
- SEXP data = R_ExternalPtrAddr(sp);
- /* Check for NULL ptr
- * This can occur if, for example, a grid grob is saved
- * and then loaded. The saved grob has its ptr null'ed
- */
- if (data == NULL)
- error("grid grob object is empty");
- return VECTOR_ELT(data, 0);
-}
-
-SEXP L_SetSEXPPtr(SEXP sp, SEXP s)
-{
- SEXP data = R_ExternalPtrAddr(sp);
- /* Check for NULL ptr
- * This can occur if, for example, a grid grob is saved
- * and then loaded. The saved grob has its ptr null'ed
- */
- if (data == NULL)
- error("grid grob object is empty");
- SET_VECTOR_ELT(data, 0, s);
- return R_NilValue;
-}
-
diff --git a/com.oracle.truffle.r.native/library/grid/src/viewport.c b/com.oracle.truffle.r.native/library/grid/src/viewport.c
deleted file mode 100644
index 29004412aef8ccd9d4f1cabfc16e731742c30b1d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grid/src/viewport.c
+++ /dev/null
@@ -1,397 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-3 Paul Murrell
- * 2003-5 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/
- */
-
-#include "grid.h"
-#include <string.h>
-
-extern int gridRegisterIndex;
-
-/* Some access methods for viewports */
-SEXP viewportX(SEXP vp) {
- return VECTOR_ELT(vp, VP_X);
-}
-
-SEXP viewportY(SEXP vp) {
- return VECTOR_ELT(vp, VP_Y);
-}
-
-SEXP viewportWidth(SEXP vp) {
- return VECTOR_ELT(vp, VP_WIDTH);
-}
-
-SEXP viewportHeight(SEXP vp) {
- return VECTOR_ELT(vp, VP_HEIGHT);
-}
-
-Rboolean viewportClip(SEXP vp) {
- return LOGICAL(VECTOR_ELT(vp, VP_CLIP))[0];
-}
-
-double viewportXScaleMin(SEXP vp) {
- return numeric(VECTOR_ELT(vp, VP_XSCALE), 0);
-}
-
-double viewportXScaleMax(SEXP vp) {
- return numeric(VECTOR_ELT(vp, VP_XSCALE), 1);
-}
-
-double viewportYScaleMin(SEXP vp) {
- return numeric(VECTOR_ELT(vp, VP_YSCALE), 0);
-}
-
-double viewportYScaleMax(SEXP vp) {
- return numeric(VECTOR_ELT(vp, VP_YSCALE), 1);
-}
-
-double viewportAngle(SEXP vp) {
- return numeric(VECTOR_ELT(vp, VP_ANGLE), 0);
-}
-
-SEXP viewportLayout(SEXP vp) {
- return VECTOR_ELT(vp, VP_LAYOUT);
-}
-
-double viewportHJust(SEXP vp) {
- return REAL(VECTOR_ELT(vp, VP_VALIDJUST))[0];
-}
-
-double viewportVJust(SEXP vp) {
- return REAL(VECTOR_ELT(vp, VP_VALIDJUST))[1];
-}
-
-SEXP viewportLayoutPosRow(SEXP vp) {
- return VECTOR_ELT(vp, VP_VALIDLPOSROW);
-}
-
-SEXP viewportLayoutPosCol(SEXP vp) {
- return VECTOR_ELT(vp, VP_VALIDLPOSCOL);
-}
-
-SEXP viewportgpar(SEXP vp) {
- return VECTOR_ELT(vp, PVP_GPAR);
-}
-
-const char* viewportFontFamily(SEXP vp) {
- return CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONTFAMILY),
- 0));
-}
-
-int viewportFont(SEXP vp) {
- return INTEGER(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONT))[0];
-}
-
-double viewportFontSize(SEXP vp) {
- return REAL(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONTSIZE))[0];
-}
-
-double viewportLineHeight(SEXP vp) {
- return REAL(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_LINEHEIGHT))[0];
-}
-
-double viewportCex(SEXP vp) {
- return numeric(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_CEX), 0);
-}
-
-SEXP viewportTransform(SEXP vp) {
- return VECTOR_ELT(vp, PVP_TRANS);
-}
-
-SEXP viewportLayoutWidths(SEXP vp) {
- return VECTOR_ELT(vp, PVP_WIDTHS);
-}
-
-SEXP viewportLayoutHeights(SEXP vp) {
- return VECTOR_ELT(vp, PVP_HEIGHTS);
-}
-
-SEXP viewportWidthCM(SEXP vp) {
- return VECTOR_ELT(vp, PVP_WIDTHCM);
-}
-
-SEXP viewportHeightCM(SEXP vp) {
- return VECTOR_ELT(vp, PVP_HEIGHTCM);
-}
-
-SEXP viewportRotation(SEXP vp) {
- return VECTOR_ELT(vp, PVP_ROTATION);
-}
-
-SEXP viewportClipRect(SEXP vp) {
- return VECTOR_ELT(vp, PVP_CLIPRECT);
-}
-
-SEXP viewportParent(SEXP vp) {
- return VECTOR_ELT(vp, PVP_PARENT);
-}
-
-SEXP viewportChildren(SEXP vp) {
- return VECTOR_ELT(vp, PVP_CHILDREN);
-}
-
-SEXP viewportDevWidthCM(SEXP vp) {
- return VECTOR_ELT(vp, PVP_DEVWIDTHCM);
-}
-
-SEXP viewportDevHeightCM(SEXP vp) {
- return VECTOR_ELT(vp, PVP_DEVHEIGHTCM);
-}
-
-SEXP viewportParentGPar(SEXP vp) {
- return VECTOR_ELT(vp, PVP_PARENTGPAR);
-}
-
-void fillViewportLocationFromViewport(SEXP vp, LViewportLocation *vpl)
-{
- vpl->x = viewportX(vp);
- vpl->y = viewportY(vp);
- vpl->width = viewportWidth(vp);
- vpl->height = viewportHeight(vp);
- vpl->hjust = viewportHJust(vp);
- vpl->vjust = viewportVJust(vp);
-}
-
-void fillViewportContextFromViewport(SEXP vp,
- LViewportContext *vpc)
-{
- vpc->xscalemin = viewportXScaleMin(vp);
- vpc->xscalemax = viewportXScaleMax(vp);
- vpc->yscalemin = viewportYScaleMin(vp);
- vpc->yscalemax = viewportYScaleMax(vp);
-}
-
-void copyViewportContext(LViewportContext vpc1, LViewportContext *vpc2)
-{
- vpc2->xscalemin = vpc1.xscalemin;
- vpc2->xscalemax = vpc1.xscalemax;
- vpc2->yscalemin = vpc1.yscalemin;
- vpc2->yscalemax = vpc1.yscalemax;
-}
-
-void gcontextFromViewport(SEXP vp, const pGEcontext gc, pGEDevDesc dd) {
- gcontextFromgpar(viewportgpar(vp), 0, gc, dd);
-}
-
-/* The idea is to produce a transformation for this viewport which
- * will take any location in INCHES and turn it into a location on the
- * Device in INCHES.
- * The reason for working in INCHES is because we want to be able to
- * do rotations as part of the transformation.
- * If "incremental" is true, then we just work from the "current"
- * values of the parent. Otherwise, we have to recurse and recalculate
- * everything from scratch.
- */
-void calcViewportTransform(SEXP vp, SEXP parent, Rboolean incremental,
- pGEDevDesc dd)
-{
- int i, j;
- double vpWidthCM, vpHeightCM, rotationAngle;
- double parentWidthCM, parentHeightCM;
- double xINCHES, yINCHES;
- double xadj, yadj;
- double parentAngle;
- LViewportLocation vpl;
- LViewportContext vpc, parentContext;
- R_GE_gcontext gc, parentgc;
- LTransform thisLocation, thisRotation, thisJustification, thisTransform;
- LTransform tempTransform, parentTransform, transform;
- SEXP currentWidthCM, currentHeightCM, currentRotation;
- SEXP currentTransform;
- /* This should never be true when we are doing an incremental
- * calculation
- */
- if (isNull(parent)) {
- /* We have a top-level viewport; the parent is the device
- */
- getDeviceSize(dd, &parentWidthCM, &parentHeightCM);
- /* For a device the transform is the identity transform
- */
- identity(parentTransform);
- /* For a device, xmin=0, ymin=0, xmax=1, ymax=1, and
- */
- parentContext.xscalemin = 0;
- parentContext.yscalemin = 0;
- parentContext.xscalemax = 1;
- parentContext.yscalemax = 1;
- /* FIXME: How do I figure out the device fontsize ?
- * From ps.options etc, ... ?
- * FIXME: How do I figure out the device lineheight ??
- * FIXME: How do I figure out the device cex ??
- * FIXME: How do I figure out the device font ??
- * FIXME: How do I figure out the device fontfamily ??
- */
- parentgc.ps = 10;
- parentgc.lineheight = 1.2;
- parentgc.cex = 1;
- parentgc.fontface = 1;
- parentgc.fontfamily[0] = '\0';
- /* The device is not rotated
- */
- parentAngle = 0;
- fillViewportLocationFromViewport(vp, &vpl);
- } else {
- /* Get parent transform (etc ...)
- * If necessary, recalculate the parent transform (etc ...)
- */
- if (!incremental)
- calcViewportTransform(parent, viewportParent(parent), 0, dd);
- /* Get information required to transform viewport location
- */
- parentWidthCM = REAL(viewportWidthCM(parent))[0];
- parentHeightCM = REAL(viewportHeightCM(parent))[0];
- parentAngle = REAL(viewportRotation(parent))[0];
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- parentTransform[i][j] =
- REAL(viewportTransform(parent))[i +3*j];
- fillViewportContextFromViewport(parent, &parentContext);
- /*
- * Don't get gcontext from parent because the most recent
- * previous gpar setting may have come from a gTree
- * So we look at this viewport's parentgpar slot instead
- *
- * WAS gcontextFromViewport(parent, &parentgc);
- */
- gcontextFromgpar(viewportParentGPar(vp), 0, &parentgc, dd);
- /* In order for the vp to get its vpl from a layout
- * it must have specified a layout.pos and the parent
- * must have a layout
- * FIXME: Actually, in addition, layout.pos.row and
- * layout.pos.col must be valid for the layout
- */
- if ((isNull(viewportLayoutPosRow(vp)) &&
- isNull(viewportLayoutPosCol(vp))) ||
- isNull(viewportLayout(parent)))
- fillViewportLocationFromViewport(vp, &vpl);
- else if (checkPosRowPosCol(vp, parent))
- calcViewportLocationFromLayout(viewportLayoutPosRow(vp),
- viewportLayoutPosCol(vp),
- parent,
- &vpl);
- }
- /* NOTE that we are not doing a transformLocn here because
- * we just want locations and dimensions (in INCHES) relative to
- * the parent, NOT relative to the device.
- */
- /* First, convert the location of the viewport into CM
- */
- xINCHES = transformXtoINCHES(vpl.x, 0, parentContext, &parentgc,
- parentWidthCM, parentHeightCM,
- dd);
- yINCHES = transformYtoINCHES(vpl.y, 0, parentContext, &parentgc,
- parentWidthCM, parentHeightCM,
- dd);
- /* Calculate the width and height of the viewport in CM too
- * so that any viewports within this one can do transformations
- */
- vpWidthCM = transformWidthtoINCHES(vpl.width, 0, parentContext, &parentgc,
- parentWidthCM, parentHeightCM,
- dd)*2.54;
- vpHeightCM = transformHeighttoINCHES(vpl.height, 0, parentContext,
- &parentgc,
- parentWidthCM,
- parentHeightCM,
- dd)*2.54;
- /* Fall out if location or size are non-finite
- */
- if (!R_FINITE(xINCHES) ||
- !R_FINITE(yINCHES) ||
- !R_FINITE(vpWidthCM) ||
- !R_FINITE(vpHeightCM))
- error(_("non-finite location and/or size for viewport"));
- /* Determine justification required
- */
- justification(vpWidthCM, vpHeightCM, vpl.hjust, vpl.vjust,
- &xadj, &yadj);
- /* Next, produce the transformation to add the location of
- * the viewport to the location.
- */
- /* Produce transform for this viewport
- */
- translation(xINCHES, yINCHES, thisLocation);
- if (viewportAngle(vp) != 0)
- rotation(viewportAngle(vp), thisRotation);
- else
- identity(thisRotation);
- translation(xadj/2.54, yadj/2.54, thisJustification);
- /* Position relative to origin of rotation THEN rotate.
- */
- multiply(thisJustification, thisRotation, tempTransform);
- /* Translate to bottom-left corner.
- */
- multiply(tempTransform, thisLocation, thisTransform);
- /* Combine with parent's transform
- */
- multiply(thisTransform, parentTransform, transform);
- /* Sum up the rotation angles
- */
- rotationAngle = parentAngle + viewportAngle(vp);
- /* Finally, allocate the rows and columns for this viewport's
- * layout if it has one
- */
- if (!isNull(viewportLayout(vp))) {
- fillViewportContextFromViewport(vp, &vpc);
- gcontextFromViewport(vp, &gc, dd);
- calcViewportLayout(vp, vpWidthCM, vpHeightCM, vpc, &gc, dd);
- }
- /* Record all of the answers in the viewport
- * (the layout calculations are done within calcViewportLayout)
- */
- PROTECT(currentWidthCM = ScalarReal(vpWidthCM));
- PROTECT(currentHeightCM = ScalarReal(vpHeightCM));
- PROTECT(currentRotation = ScalarReal(rotationAngle));
- PROTECT(currentTransform = allocMatrix(REALSXP, 3, 3));
- for (i=0; i<3; i++)
- for (j=0; j<3; j++)
- REAL(currentTransform)[i + 3*j] = transform[i][j];
- SET_VECTOR_ELT(vp, PVP_WIDTHCM, currentWidthCM);
- SET_VECTOR_ELT(vp, PVP_HEIGHTCM, currentHeightCM);
- SET_VECTOR_ELT(vp, PVP_ROTATION, currentRotation);
- SET_VECTOR_ELT(vp, PVP_TRANS, currentTransform);
- UNPROTECT(4);
-}
-
-void initVP(pGEDevDesc dd)
-{
- SEXP vpfnname, vpfn, vp;
- SEXP xscale, yscale;
- SEXP currentgp = gridStateElement(dd, GSS_GPAR);
- SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
- PROTECT(vpfnname = findFun(install("grid.top.level.vp"), R_gridEvalEnv));
- PROTECT(vpfn = lang1(vpfnname));
- PROTECT(vp = eval(vpfn, R_GlobalEnv));
- /*
- * Set the "native" scale of the top viewport to be the
- * natural device coordinate system (e.g., points in
- * postscript, pixels in X11, ...)
- */
- PROTECT(xscale = allocVector(REALSXP, 2));
- REAL(xscale)[0] = dd->dev->left;
- REAL(xscale)[1] = dd->dev->right;
- SET_VECTOR_ELT(vp, VP_XSCALE, xscale);
- PROTECT(yscale = allocVector(REALSXP, 2));
- REAL(yscale)[0] = dd->dev->bottom;
- REAL(yscale)[1] = dd->dev->top;
- SET_VECTOR_ELT(vp, VP_YSCALE, yscale);
- SET_VECTOR_ELT(vp, PVP_GPAR, currentgp);
- vp = doSetViewport(vp, TRUE, TRUE, dd);
- SET_VECTOR_ELT(gsd, GSS_VP, vp);
- UNPROTECT(5);
-}
-
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
index 2821716614aecf0854f0b63cd0fee013341867f0..60e4558d819e7d54cd818d58f21d2f0d22d30f1e 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
@@ -28,6 +28,7 @@ import com.oracle.truffle.r.library.graphics.GraphicsCCalls;
import com.oracle.truffle.r.library.graphics.GraphicsCCalls.C_Par;
import com.oracle.truffle.r.library.graphics.GraphicsCCalls.C_PlotXY;
import com.oracle.truffle.r.library.grid.GridFunctionsFactory.InitGridNodeGen;
+import com.oracle.truffle.r.library.grid.GridFunctionsFactory.ValidUnitsNodeGen;
import com.oracle.truffle.r.library.methods.MethodsListDispatchFactory.R_M_setPrimitiveMethodsNodeGen;
import com.oracle.truffle.r.library.methods.MethodsListDispatchFactory.R_externalPtrPrototypeObjectNodeGen;
import com.oracle.truffle.r.library.methods.MethodsListDispatchFactory.R_getClassFromCacheNodeGen;
@@ -511,6 +512,8 @@ public class ForeignFunctions {
// grid
case "L_initGrid":
return InitGridNodeGen.create();
+ case "L_validUnits":
+ return ValidUnitsNodeGen.create();
// parallel
case "mc_is_child":
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RVersionNumber.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RVersionNumber.java
index 7f3cc835154e1a2accd58dfa0cc79cf677fc79c0..4dcd65278766088267f90a7368a449b0761ec549 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RVersionNumber.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RVersionNumber.java
@@ -33,9 +33,9 @@ package com.oracle.truffle.r.runtime;
public class RVersionNumber {
public static final String MAJOR = "3";
public static final String MINOR = "3";
- public static final String PATCH = "1";
+ public static final String PATCH = "2";
- public static final int R_VERSION = (3 << 16) + (3 << 8) + 1;
+ public static final int R_VERSION = (3 << 16) + (3 << 8) + 2;
public static final String MAJOR_MINOR = MAJOR + "." + MINOR;
public static final String MINOR_PATCH = MINOR + "." + PATCH;
@@ -43,8 +43,8 @@ public class RVersionNumber {
public static final String R_HYPHEN_FULL = "R-" + FULL;
public static final String RELEASE_YEAR = "2016";
- public static final String RELEASE_MONTH = "06";
- public static final String RELEASE_DAY = "21";
+ public static final String RELEASE_MONTH = "10";
+ public static final String RELEASE_DAY = "11";
public static final String VERSION_STRING = "FastR version " + FULL + " (" + RELEASE_YEAR + "-" + RELEASE_MONTH + "-" + RELEASE_DAY + ")";
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
index 872652954e2863f1c016e2ffffbaf8ebebd4cfa8..2ea3673fc769138890b6339c11d97967f096c9e9 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
@@ -158,7 +158,7 @@ Class: numeric
#{ gen<-function(object) 0; setGeneric("gen"); res<-print(gen); removeGeneric("gen"); res }
function (object)
standardGeneric("gen")
-<environment: 0x7fd033a4a478>
+<environment: 0x7fe323e45660>
attr(,"generic")
[1] "gen"
attr(,"generic")attr(,"package")
@@ -192,7 +192,7 @@ standardGeneric for "gen" defined from package ".GlobalEnv"
function (object)
standardGeneric("gen")
-<environment: 0x7fd033a4a478>
+<environment: 0x7fe323e45660>
Methods may be defined for arguments: object
Use showMethods("gen") for currently available ones.
@@ -219,7 +219,7 @@ Creating a generic function for ‘diag<-’ from package ‘base’ in the glob
##com.oracle.truffle.r.test.S4.TestS4.testMethods#Ignored.OutputFormatting#
#{ setGeneric("gen", function(object) standardGeneric("gen")); res<-print(gen); removeGeneric("gen"); res }
function(object) standardGeneric("gen")
-<environment: 0x7f89ecc1b028>
+<environment: 0x7fba68bbb3c0>
attr(,"generic")
[1] "gen"
attr(,"generic")attr(,"package")
@@ -246,7 +246,7 @@ standardGeneric for "gen" defined from package ".GlobalEnv"
function (object)
standardGeneric("gen")
-<environment: 0x7f89ecc1b028>
+<environment: 0x7fba68bbb3c0>
Methods may be defined for arguments: object
Use showMethods("gen") for currently available ones.
@@ -1200,7 +1200,7 @@ Error in .Primitive(c("c", "b")) : string argument required
##com.oracle.truffle.r.test.builtins.TestBuiltin_Primitive.testPrimitive1#Ignored.ImplementationError#
#argv <- list('c');.Primitive(argv[[1]]);
-function (..., recursive = FALSE) .Primitive("c")
+function (...) .Primitive("c")
##com.oracle.truffle.r.test.builtins.TestBuiltin_RNGkind.testArgsCast#Output.IgnoreErrorMessage#
#.Internal(RNGkind('abc', NULL))
@@ -9433,7 +9433,7 @@ numeric(0)
##com.oracle.truffle.r.test.builtins.TestBuiltin_bitwiseAnd.testBitwiseFunctions#Output.IgnoreErrorContext#Output.IgnoreErrorMessage#
#{ bitwAnd(NULL, NULL) }
-Error in bitwAnd(NULL, NULL) : negative length vectors are not allowed
+Error in bitwAnd(NULL, NULL) : unimplemented type 'NULL' in 'bitwAnd'
##com.oracle.truffle.r.test.builtins.TestBuiltin_bitwiseAnd.testBitwiseFunctions#Output.IgnoreErrorContext#Output.IgnoreErrorMessage#
#{ bitwAnd(c(), c(1,2,3)) }
@@ -10225,7 +10225,7 @@ x y
##com.oracle.truffle.r.test.builtins.TestBuiltin_c.testCombine#Output.ContainsReferences#
#{ e1 <- new.env(); c(e1, 3) }
[[1]]
-<environment: 0x7f926afe0180>
+<environment: 0x7fd3828cdf80>
[[2]]
[1] 3
@@ -10234,10 +10234,10 @@ x y
##com.oracle.truffle.r.test.builtins.TestBuiltin_c.testCombine#Output.ContainsReferences#
#{ e1 <- new.env(); e2 <- new.env(); c(e1, e2) }
[[1]]
-<environment: 0x7fbbab815ae0>
+<environment: 0x7f90e9ba4ae0>
[[2]]
-<environment: 0x7fbbab816698>
+<environment: 0x7f90e9ba6698>
##com.oracle.truffle.r.test.builtins.TestBuiltin_c.testCombine#
@@ -15497,7 +15497,7 @@ character(0)
##com.oracle.truffle.r.test.builtins.TestBuiltin_date.testDate#Ignored.Unknown#
#{date()}
-[1] "Mon Oct 31 22:14:56 2016"
+[1] "Wed Nov 9 20:10:56 2016"
##com.oracle.truffle.r.test.builtins.TestBuiltin_delayedAssign.testDelayedAssign#
#{ delayedAssign("x", a+b); a <- 1 ; b <- 3 ; x }
@@ -20781,7 +20781,7 @@ description class mode text opened can read
##com.oracle.truffle.r.test.builtins.TestBuiltin_getNamespaceVersion.testgetNamespaceVersion1#
#argv <- structure(list(ns = 'stats'), .Names = 'ns');do.call('getNamespaceVersion', argv)
version
-"3.3.1"
+"3.3.2"
##com.oracle.truffle.r.test.builtins.TestBuiltin_getRestart.testgetRestart1#
#argv <- list(2L); .Internal(.getRestart(argv[[1]]))
@@ -28537,9 +28537,10 @@ character(0)
##com.oracle.truffle.r.test.builtins.TestBuiltin_listfiles.testlistfiles3#Ignored.Unknown#
#argv <- list('.', '^CITATION.*', FALSE, FALSE, TRUE, FALSE, FALSE, FALSE); .Internal(list.files(argv[[1]], argv[[2]], argv[[3]], argv[[4]], argv[[5]], argv[[6]], argv[[7]], argv[[8]]))
-[1] "com.oracle.truffle.r.native/gnur/R-3.3.1/library/base/CITATION"
-[2] "com.oracle.truffle.r.native/gnur/R-3.3.1/src/library/base/inst/CITATION"
+[1] "com.oracle.truffle.r.native/gnur/R-3.3.2/library/base/CITATION"
+[2] "com.oracle.truffle.r.native/gnur/R-3.3.2/src/library/base/inst/CITATION"
[3] "library/base/CITATION"
+[4] "rlibs/lattice/CITATION"
##com.oracle.truffle.r.test.builtins.TestBuiltin_listfiles.testlistfiles4#
#argv <- list('mgcv', NULL, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE); .Internal(list.files(argv[[1]], argv[[2]], argv[[3]], argv[[4]], argv[[5]], argv[[6]], argv[[7]], argv[[8]]))
@@ -32610,20 +32611,20 @@ Error in argv[[4]] : subscript out of bounds
##com.oracle.truffle.r.test.builtins.TestBuiltin_newenv.testnewenv#Output.ContainsReferences#
#e <- new.env(); e; parent.env(new.env(TRUE, e))
-<environment: 0x7fb18c6c5e30>
-<environment: 0x7fb18c6c5e30>
+<environment: 0x7fb9e3fb6a08>
+<environment: 0x7fb9e3fb6a08>
##com.oracle.truffle.r.test.builtins.TestBuiltin_newenv.testnewenv#Output.ContainsReferences#
#new.env()
-<environment: 0x7ff8dc57e710>
+<environment: 0x7f8d3b3a26e8>
##com.oracle.truffle.r.test.builtins.TestBuiltin_newenv.testnewenv#Output.ContainsReferences#
#new.env(1,,2)
-<environment: 0x7fe42e9ef318>
+<environment: 0x7fd0f3598898>
##com.oracle.truffle.r.test.builtins.TestBuiltin_newenv.testnewenv#Output.ContainsReferences#
#new.env(logical(),new.env(),1000)
-<environment: 0x7ff3714fcd58>
+<environment: 0x7fa403368158>
##com.oracle.truffle.r.test.builtins.TestBuiltin_newenv.testnewenv#Output.ContainsReferences#
#parent.env(new.env())
@@ -37990,7 +37991,7 @@ Error in parent.env(c(1, 2, 3)) : argument is not an environment
##com.oracle.truffle.r.test.builtins.TestBuiltin_parentenvassign.testParentEnv#Output.ContainsReferences#
#e <- new.env(); e2 <- new.env(); parent.env(e) <- e2; parent.env(e)
-<environment: 0x7fc92a598f48>
+<environment: 0x7f834630df48>
##com.oracle.truffle.r.test.builtins.TestBuiltin_parentenvassign.testParentEnv#Output.IgnoreErrorContext#
#e <- new.env(); parent.env(e) <- 44
@@ -39553,7 +39554,7 @@ function (e1, e2) .Primitive("+")
##com.oracle.truffle.r.test.builtins.TestBuiltin_printfunction.testprintfunction3#Ignored.Unknown#
#argv <- list(.Primitive('c'), TRUE); .Internal(print.function(argv[[1]], argv[[2]]))
-function (..., recursive = FALSE) .Primitive("c")
+function (...) .Primitive("c")
##com.oracle.truffle.r.test.builtins.TestBuiltin_printfunction.testprintfunction4#
#argv <- list(.Primitive('.Internal'), TRUE); .Internal(print.function(argv[[1]], argv[[2]]))
@@ -44434,59 +44435,59 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote("bar"), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
[26] 09 00 00 00 03 62 61 72
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote('asdf'), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
[26] 09 00 00 00 04 61 73 64 66
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote('baz'), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 10 00 00 00 01 00 04 00
[26] 09 00 00 00 03 62 61 7a
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#Ignored.ImplementationError#
#options(keep.source=FALSE); serialize(quote((a %asdf% b)), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 28 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00
[51] 06 25 61 73 64 66 25 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00
[76] 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#Ignored.ImplementationError#
#options(keep.source=FALSE); serialize(quote((a+b)), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 28 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00
[51] 01 2b 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00 00 02 00 00
[76] 00 01 00 04 00 09 00 00 00 01 62 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(111+11), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 2b 00 00 00 02 00 00 00 0e 00 00 00 01 40 5b c0 00 00 00 00
[51] 00 00 00 00 02 00 00 00 0e 00 00 00 01 40 26 00 00 00 00 00 00 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(111+8i), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 2b 00 00 00 02 00 00 00 0e 00 00 00 01 40 5b c0 00 00 00 00
[51] 00 00 00 00 02 00 00 00 0f 00 00 00 01 00 00 00 00 00 00 00 00 40 20 00 00
[76] 00 00 00 00 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(111L), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0d 00 00 00 01 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0d 00 00 00 01 00 00 00
[26] 6f
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(FALSE), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0a 00 00 00 01 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0a 00 00 00 01 00 00 00
[26] 00
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(NA_character_ + NA_complex_ + NA_integer_ + NA_real_), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 2b 00 00 00 02 00 00 00 06 00 00 01 ff 00 00 00 02 00 00 00
[51] 06 00 00 01 ff 00 00 00 02 00 00 00 10 00 00 00 01 00 00 00 09 ff ff ff ff
[76] 00 00 00 02 00 00 00 0f 00 00 00 01 7f f0 00 00 00 00 07 a2 7f f0 00 00 00
@@ -44496,32 +44497,32 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(NA_character_), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 10 00 00 00 01 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 10 00 00 00 01 00 00 00
[26] 09 ff ff ff ff
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(NA_complex_), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0f 00 00 00 01 7f f0 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0f 00 00 00 01 7f f0 00
[26] 00 00 00 07 a2 7f f0 00 00 00 00 07 a2
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(NA_integer_), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0d 00 00 00 01 80 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0d 00 00 00 01 80 00 00
[26] 00
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(NA_real_), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0e 00 00 00 01 7f f0 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0e 00 00 00 01 7f f0 00
[26] 00 00 00 07 a2
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(TRUE), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 0a 00 00 00 01 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 0a 00 00 00 01 00 00 00
[26] 01
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(a(b(c(d(function (e, ...) { f(g)$h.i}))))), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 61 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00
[51] 01 62 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 63 00 00
[76] 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 64 00 00 00 02 00 00
@@ -44537,27 +44538,27 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(a+b), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 2b 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00
[51] 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(f(g)$h.i), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 24 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00
[51] 01 66 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 67 00 00 00 fe 00 00
[76] 00 02 00 00 00 01 00 04 00 09 00 00 00 03 68 2e 69 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(foo(a,b,c)), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 03 66 6f 6f 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61
[51] 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 02 00 00 00 01
[76] 00 04 00 09 00 00 00 01 63 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function() new("foo", x)), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 00 fe 00 00 00 02
[51] 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 03 6e 65 77 00 00 00 02 00 00
[76] 00 10 00 00 00 01 00 04 00 09 00 00 00 03 66 6f 6f 00 00 00 02 00 00 00 01
@@ -44565,7 +44566,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#Ignored.ImplementationError#
#options(keep.source=FALSE); serialize(quote(function(x) { `+`(`(`("BAR"), x) }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 00 fe 00 00 00 02 00 00 00 06
[76] 00 00 00 01 00 04 00 09 00 00 00 01 7b 00 00 00 02 00 00 00 06 00 00 00 01
@@ -44576,7 +44577,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x) { new("BAR", x) }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 00 fe 00 00 00 02 00 00 00 06
[76] 00 00 00 01 00 04 00 09 00 00 00 01 7b 00 00 00 02 00 00 00 06 00 00 00 01
@@ -44586,7 +44587,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x, ...) { new("BAR", x) }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09
[76] 00 00 00 03 2e 2e 2e 00 00 00 fb 00 00 00 fe 00 00 00 02 00 00 00 06 00 00
@@ -44597,7 +44598,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x,y) { TRUE }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09
[76] 00 00 00 01 79 00 00 00 fb 00 00 00 fe 00 00 00 02 00 00 00 06 00 00 00 01
@@ -44606,7 +44607,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x,y) { new("BAR", x) }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09
[76] 00 00 00 01 79 00 00 00 fb 00 00 00 fe 00 00 00 02 00 00 00 06 00 00 00 01
@@ -44617,7 +44618,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x,y,...) { 1 }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09
[76] 00 00 00 01 79 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 03
@@ -44627,7 +44628,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x,y=1,...) { NA }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 fb 00 00 04 02 00 00 00 01 00 04 00 09
[76] 00 00 00 01 79 00 00 00 0e 00 00 00 01 3f f0 00 00 00 00 00 00 00 00 04 02
@@ -44638,7 +44639,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x={1 + a},y,...) { !!NA }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01
[76] 7b 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 2b 00 00 00
@@ -44652,7 +44653,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x={1 + a},y,...) { !1+5i }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01
[76] 7b 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 2b 00 00 00
@@ -44668,7 +44669,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x={1 + a},y,...) { NA }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01
[76] 7b 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 2b 00 00 00
@@ -44681,7 +44682,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(function(x={1 + a},y=c(1,2,3),z="foo",...) { !1+5i }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 08 66 75 6e 63 74 69 6f 6e 00 00 00 02 00 00 04 02 00 00 00 01
[51] 00 04 00 09 00 00 00 01 78 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01
[76] 7b 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 2b 00 00 00
@@ -44701,7 +44702,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(if (a * 2 < 199) b + foo(x,y,foo=z+1,bar=)), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 02 69 66 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00
[51] 00 01 3c 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 2a 00
[76] 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00 00 02 00 00 00 0e 00
@@ -44718,14 +44719,14 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(if (a) b else c), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 02 69 66 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00
[51] 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 02 00 00 00 01 00
[76] 04 00 09 00 00 00 01 63 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(if (a) {b} else {c}), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 02 69 66 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00
[51] 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 01 7b 00 00 00 02 00
[76] 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 fe 00 00 00 02 00 00 00 06 00
@@ -44734,7 +44735,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(if ({a}) {b} else {c}), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 02 69 66 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00
[51] 00 01 7b 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00 00 fe 00
[76] 00 00 02 00 00 00 06 00 00 02 ff 00 00 00 02 00 00 00 01 00 04 00 09 00 00
@@ -44743,7 +44744,7 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(repeat {b; if (c) next else break}), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 06 72 65 70 65 61 74 00 00 00 02 00 00 00 06 00 00 00 01 00 04
[51] 00 09 00 00 00 01 7b 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00
[76] 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00 02 69 66 00 00 00 02
@@ -44754,18 +44755,18 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(while (a) b), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 05 77 68 69 6c 65 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00
[51] 01 61 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote(x), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 01 00 04 00 09 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 01 00 04 00 09 00 00 00
[26] 01 78
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); serialize(quote({ foo(a,b,c) }), connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 06 00 00 00 01 00 04 00
[26] 09 00 00 00 01 7b 00 00 00 02 00 00 00 06 00 00 00 01 00 04 00 09 00 00 00
[51] 03 66 6f 6f 00 00 00 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00 00 02
[76] 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 02 00 00 00 01 00 04 00 09
@@ -44773,60 +44774,60 @@ Error in seq.int(argv[[1]], argv[[2]], argv[[3]]) :
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- defaultPrototype(); serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 01 00 19
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 01 00 19
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- list(enclos = new.env(hash=FALSE)); serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 02 13 00 00 00 01 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 02 13 00 00 00 01 00 00 00
[26] 04 00 00 00 00 00 00 00 fd 00 00 00 fe 00 00 00 fe 00 00 00 fe 00 00 04 02
[51] 00 00 00 01 00 04 00 09 00 00 00 05 6e 61 6d 65 73 00 00 00 10 00 00 00 01
[76] 00 04 00 09 00 00 00 06 65 6e 63 6c 6f 73 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$a <- 'foo'; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 61 00 00 00 10 00 00 00
[51] 01 00 04 00 09 00 00 00 03 66 6f 6f 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$b <- 123; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 62 00 00 00 0e 00 00 00
[51] 01 40 5e c0 00 00 00 00 00 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$c <- 1233L; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 63 00 00 00 0d 00 00 00
[51] 01 00 00 04 d1 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$d <- TRUE; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 64 00 00 00 0a 00 00 00
[51] 01 00 00 00 01 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$e <- 5+9i; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 65 00 00 00 0f 00 00 00
[51] 01 40 14 00 00 00 00 00 00 40 22 00 00 00 00 00 00 00 00 00 fe 00 00 00 fe
[76] 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#options(keep.source=FALSE); val <- new.env(hash=FALSE); val$f <- NA; serialize(val, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 00 00 04 00 00 00 00 00 00 00
[26] fd 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 66 00 00 00 0a 00 00 00
[51] 01 80 00 00 00 00 00 00 fe 00 00 00 fe 00 00 00 fe
##com.oracle.truffle.r.test.builtins.TestBuiltin_serialize.testserialize#
#setClass('foo', slots = c(x='numeric', y='numeric')); t1 <- new('foo', x=4, y=c(77,88)); options(keep.source=FALSE); serialize(t1, connection=NULL)
- [1] 58 0a 00 00 00 02 00 03 03 01 00 02 03 00 00 01 03 19 00 00 04 02 00 00 00
+ [1] 58 0a 00 00 00 02 00 03 03 02 00 02 03 00 00 01 03 19 00 00 04 02 00 00 00
[26] 01 00 04 00 09 00 00 00 01 78 00 00 00 0e 00 00 00 01 40 10 00 00 00 00 00
[51] 00 00 00 04 02 00 00 00 01 00 04 00 09 00 00 00 01 79 00 00 00 0e 00 00 00
[76] 02 40 53 40 00 00 00 00 00 40 56 00 00 00 00 00 00 00 00 04 02 00 00 00 01
@@ -51173,25 +51174,25 @@ Error in tracemem(NULL) : cannot trace NULL
##com.oracle.truffle.r.test.builtins.TestBuiltin_tracemem.list#Output.ContainsReferences#
#v <- list(1,10,100); tracemem(v); x <- v; x[[1]]<-42;
-[1] "<0x7ffa23d66a40>"
-tracemem[0x7ffa23d66a40 -> 0x7ffa23d668d8]:
+[1] "<0x7f878bbeec90>"
+tracemem[0x7f878bbeec90 -> 0x7f878bbeeb28]:
##com.oracle.truffle.r.test.builtins.TestBuiltin_tracemem.retracemem#Output.ContainsReferences#
#v <- c(1,10,100); tracemem(v); x <- v[-1]; retracemem(x, retracemem(v)); u <- x; u[[1]] <- 42;
-[1] "<0x7f877ed86040>"
-tracemem[<0x7f877ed86040> -> 0x7f877c8d7150]:
-tracemem[0x7f877c8d7150 -> 0x7f877c8d7188]:
+[1] "<0x7faf1a058090>"
+tracemem[<0x7faf1a058090> -> 0x7faf191a98a8]:
+tracemem[0x7faf191a98a8 -> 0x7faf191a98e0]:
##com.oracle.truffle.r.test.builtins.TestBuiltin_tracemem.vectors#Output.ContainsReferences#
#v <- c(1,10,100); tracemem(v); x <- v; y <- v; x[[1]]<-42; untracemem(v); y[[2]] <- 84
-[1] "<0x7f893adfda40>"
-tracemem[0x7f893adfda40 -> 0x7f893adfd890]:
+[1] "<0x7ff2cd448c90>"
+tracemem[0x7ff2cd448c90 -> 0x7ff2cd448ae0]:
##com.oracle.truffle.r.test.builtins.TestBuiltin_tracemem.vectors#Output.ContainsReferences#
#v <- c(1,10,100); tracemem(v); x <- v; y <- v; x[[1]]<-42; y[[2]] <- 84
-[1] "<0x7f89f6d86c40>"
-tracemem[0x7f89f6d86c40 -> 0x7f89f6d86a90]:
-tracemem[0x7f89f6d86c40 -> 0x7f89f6d86a00]:
+[1] "<0x7f818486bc90>"
+tracemem[0x7f818486bc90 -> 0x7f818486bae0]:
+tracemem[0x7f818486bc90 -> 0x7f818486ba50]:
##com.oracle.truffle.r.test.builtins.TestBuiltin_trigamma.testtrigamma1#Ignored.Unknown#
#argv <- list(structure(c(9.16602362697115, 1.16602362697115, 3.16602362697115, 6.16602362697115, 6.16602362697115, 2.16602362697115, 8.16602362697115, 1.16602362697115, 7.16602362697115, 19.1660236269712, 2.16602362697115), .Names = c('1', '2', '3', '4', '5', '6', '7', '8', '9', '10', '11')));trigamma(argv[[1]]);
@@ -57260,7 +57261,7 @@ Error: attempt to apply non-function
function (x, where = -1, envir = if (missing(frame)) as.environment(where) else sys.frame(frame),
frame, mode = "any", inherits = TRUE)
.Internal(exists(x, envir, mode, inherits))
-<bytecode: 0x7fe8c9979ae0>
+<bytecode: 0x7fcbd1979320>
<environment: namespace:base>
##com.oracle.truffle.r.test.functions.TestFunctions.testFunctionPrinting#
@@ -99034,8 +99035,8 @@ Error in `[[<-`(`*tmp*`, 1 + (0+1i), 1, value = 7) :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testComplexIndex#Ignored.Unstable#Output.IgnoreErrorContext#
#{ x<-c(1,2,3,4); dim(x)<-c(2,2); x[[1+1i, 1]]<-NULL }
-Error in `[[<-`(`*tmp*`, 1 + (0+1i), 1, value = NULL) :
- invalid subscript type 'complex'
+Error in x[[1 + (0+1i), 1]] <- NULL :
+ more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testComplexIndex#Output.IgnoreErrorMessage#
#{ x<-c(1,2,3,4); dim(x)<-c(2,2); x[[1+1i, 1]]<-c(7,42) }
@@ -100331,7 +100332,7 @@ Error in z[[list()]] <- 42 :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testListIndex#Ignored.Unknown#Output.IgnoreErrorContext#
#{ z<-1:4; z[[list()]]<-NULL }
Error in z[[list()]] <- NULL :
- more elements supplied than there are to replace
+ attempt to select less than one element in OneIndex
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testListIndex#Output.IgnoreErrorMessage#
#{ z<-1:4; z[[list()]]<-integer() }
@@ -101944,7 +101945,7 @@ Error in b[[0]] <- NULL :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ b<-3:5; dim(b) <- c(1,3) ; b[[c(1)]] <- NULL ; b }
Error in b[[c(1)]] <- NULL :
- more elements supplied than there are to replace
+ incompatible types (from NULL to integer) in [[ assignment
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorContext#
#{ b<-3:5; dim(b) <- c(1,3) ; b[[c(1,2)]] <- NULL ; b }
@@ -102466,17 +102467,17 @@ NULL
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x <- c(1) ; x[[NA]] <- NULL ; x }
Error in x[[NA]] <- NULL :
- attempt to select less than one element in integerOneIndex
+ more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x <- c(1); x[[-4]] <- NULL }
Error in x[[-4]] <- NULL :
- more elements supplied than there are to replace
+ attempt to select less than one element in integerOneIndex
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x <- c(1,2) ; x[[NA]] <- NULL ; x }
Error in x[[NA]] <- NULL :
- more elements supplied than there are to replace
+ attempt to select more than one element in integerOneIndex
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x <- c(1,2,3) ; x[[NA]] <- NULL ; x }
@@ -103050,7 +103051,7 @@ Error in x[[0]] <- NULL :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x<-1:4; x[[1]]<-NULL; x }
Error in x[[1]] <- NULL :
- incompatible types (from NULL to integer) in [[ assignment
+ more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#
#{ x<-1:4; x[[1]]<-c(1,1); x }
@@ -103349,7 +103350,7 @@ Error in x[[-4]] <- 7 :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x<-c(1,2,3); x[[-4]]<-NULL }
Error in x[[-4]] <- NULL :
- attempt to select more than one element in integerOneIndex
+ more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#
#{ x<-c(1,2,3,4); dim(x)<-c(2,2); x[1,1]<-NULL; x }
@@ -103368,7 +103369,7 @@ Error in x[[1, 1]] <- NULL :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x<-c(1,2,3,4); dim(x)<-c(2,2); x[[1]]<-NULL; x }
Error in x[[1]] <- NULL :
- incompatible types (from NULL to double) in [[ assignment
+ more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testMoreVectorsOther#Output.IgnoreErrorMessage#
#{ x<-c(1,2,3,4); dim(x)<-c(2,2); x[[as.raw(1), 1]]<-NULL }
@@ -107301,8 +107302,7 @@ Error in b[2] <- v :
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testScalarUpdate#Ignored.Unstable#
#{ f <- function(b,v) { b[[2]] <- v ; b } ; f(c("a","b"),"d") ; f(c("a","b"),NULL) }
-Error in b[[2]] <- v :
- incompatible types (from NULL to character) in [[ assignment
+Error in b[[2]] <- v : more elements supplied than there are to replace
##com.oracle.truffle.r.test.library.base.TestSimpleVectors.testScalarUpdate#
#{ f <- function(b,v) { b[[2]] <- v ; b } ; f(list(TRUE,NA),FALSE) ; f(3,3) }
diff --git a/mx.fastr/copyrights/gnu_r_murrel_core.copyright.star.regex b/mx.fastr/copyrights/gnu_r_murrel_core.copyright.star.regex
new file mode 100644
index 0000000000000000000000000000000000000000..6498dd0ea467db1e78e810f79f49ad8fff826efb
--- /dev/null
+++ b/mx.fastr/copyrights/gnu_r_murrel_core.copyright.star.regex
@@ -0,0 +1 @@
+/\*\n \* This material is distributed under the GNU General Public License\n \* Version 2. You may review the terms of this license at\n \* http://www.gnu.org/licenses/gpl-2.0.html\n \*\n \* Copyright \(C\) 2001-3 Paul Murrell\n \* Copyright \(c\) (?:[1-2][09][0-9][0-9]-)?[1-2][09][0-9][0-9], The R Core Team\n \* Copyright \(c\) (?:(20[0-9][0-9]), )?(20[0-9][0-9]), Oracle and/or its affiliates\n \*\n \* All rights reserved.\n \*/\n.*
diff --git a/mx.fastr/copyrights/gnu_r_murrell_core.copyright.star b/mx.fastr/copyrights/gnu_r_murrell_core.copyright.star
new file mode 100644
index 0000000000000000000000000000000000000000..00d32c02206649adf788534cfcaf573f2f506660
--- /dev/null
+++ b/mx.fastr/copyrights/gnu_r_murrell_core.copyright.star
@@ -0,0 +1,11 @@
+/*
+ * 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) 2001-3 Paul Murrell
+ * Copyright (c) 1998-2013, The R Core Team
+ * Copyright (c) 2013, 2016, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
diff --git a/mx.fastr/copyrights/overrides b/mx.fastr/copyrights/overrides
index 126f5fb24e595d2360f8667fbbe4bc06dd809ac8..204b1889bef3b1be2f1fd565c36f48e20bcef9f5 100644
--- a/mx.fastr/copyrights/overrides
+++ b/mx.fastr/copyrights/overrides
@@ -25,6 +25,7 @@ com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grDevices/DevicesC
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grDevices/fastrgd/FastRGraphicsDevice.java,gnu_r_graphics.copyright
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grDevices/NullGraphicsDevice.java,gnu_r_graphics.copyright
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grDevices/pdf/PdfGraphicsDevice.java,gnu_r_graphics.copyright
+com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/grid/GridFunctions.java,gnu_r_murrel_core.copyright
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/methods/MethodsListDispatch.java,gnu_r.copyright
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/methods/Slot.java,gnu_r.copyright
com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/Arithmetic.java,gnu_r_gentleman_ihaka.copyright
@@ -82,17 +83,6 @@ com.oracle.truffle.r.native/fficall/src/jni/Rembedded.c,gnu_r.copyright
com.oracle.truffle.r.native/include/src/libintl.h,no.copyright
com.oracle.truffle.r.native/library/base/src/registration.c,no.copyright
com.oracle.truffle.r.native/library/grDevices/src/gzio.c,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/library/grid/src/gpar.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/grid.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/grid.h,no.copyright
-com.oracle.truffle.r.native/library/grid/src/just.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/layout.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/matrix.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/register.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/state.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/unit.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/util.c,no.copyright
-com.oracle.truffle.r.native/library/grid/src/viewport.c,no.copyright
com.oracle.truffle.r.native/library/methods/src/methods_dummy.c,no.copyright
com.oracle.truffle.r.native/library/parallel/src/glpi.h,no.copyright
com.oracle.truffle.r.native/library/parallel/src/rngstream.c,no.copyright
diff --git a/mx.fastr/mx_fastr.py b/mx.fastr/mx_fastr.py
index eb145f15c27e02aedfa50ffe523d45476ad36c99..d0711cbe700ca57526a8c095ebd5ab1c0c3c6fc9 100644
--- a/mx.fastr/mx_fastr.py
+++ b/mx.fastr/mx_fastr.py
@@ -60,7 +60,7 @@ def r_path():
def r_version():
# Could figure this out dynamically
- return 'R-3.3.1'
+ return 'R-3.3.2'
def get_default_jdk():
if _mx_graal:
diff --git a/mx.fastr/suite.py b/mx.fastr/suite.py
index 63ef682bce091569d03d3224022cd192b0b5428a..ca56e3bcf90a8d49e67b6bcafeac06575c2e1972 100644
--- a/mx.fastr/suite.py
+++ b/mx.fastr/suite.py
@@ -60,9 +60,9 @@ suite = {
# explicitly referenced in the Parser annotation processor.
"libraries" : {
"GNUR" : {
- "path" : "libdownloads/R-3.3.1.tar.gz",
- "urls" : ["http://cran.rstudio.com/src/base/R-3/R-3.3.1.tar.gz"],
- "sha1" : "df853188d3e2b1c2d32393016401c432a5192c4d",
+ "path" : "libdownloads/R-3.3.2.tar.gz",
+ "urls" : ["http://cran.rstudio.com/src/base/R-3/R-3.3.2.tar.gz"],
+ "sha1" : "0e39e9c2d28fe6bab9c55ca23e08ba8727fd2fca",
"resource" : "true"
},