Logo Search packages:      
Sourcecode: r-base-core-ra version File versions  Download package

plot.c

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2008  Robert Gentleman, Ross Ihaka and the
 *                      R Development Core Team
 *  Copyright (C) 2002--2004  The R Foundation
 *
 *  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/
 */

/* <UTF8> char here is either ASCII or handled as a whole */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <Defn.h>
#include <Graphics.h>
#include <Colors.h> /* for isNAcol */
#include <Print.h>

#define imax2(x, y) ((x < y) ? y : x)

static R_INLINE double fmin2(double x, double y)
{
      if (ISNAN(x) || ISNAN(y))
            return x + y;
      return (x < y) ? x : y;
}

static R_INLINE double fmax2(double x, double y)
{
      if (ISNAN(x) || ISNAN(y))
            return x + y;
      return (x < y) ? y : x;
}


/*  P A R A M E T E R    U T I L I T I E S  */

/*
 * Extract specified par from list of inline pars
 */
static SEXP getInlinePar(SEXP s, char *name)
{
    SEXP result = R_NilValue;
    int found = 0;
    if (isList(s) && !found) {
      while (s != R_NilValue) {
          if (isList(CAR(s))) {
            result = getInlinePar(CAR(s), name);
            if (result)
                found = 1;
          } else
            if (TAG(s) != R_NilValue)
                if (!strcmp(CHAR(PRINTNAME(TAG(s))), name)) {
                  result = CAR(s);
                  found = 1;
                }
          s = CDR(s);
      }
    }
    return result;
}

/* dflt used to be used for < 0 values in R < 2.7.0,
   now just used for NULL */
static SEXP FixupPch(SEXP pch, int dflt)
{
    int i, n;
    SEXP ans = R_NilValue;/* -Wall*/

    n = length(pch);
    if (n == 0) return ans = ScalarInteger(dflt);

    PROTECT(ans = allocVector(INTSXP, n));
    if (isList(pch)) {
      for (i = 0; pch != R_NilValue;      pch = CDR(pch))
          INTEGER(ans)[i++] = asInteger(CAR(pch));
    }
    else if (isInteger(pch)) {
      for (i = 0; i < n; i++)
          INTEGER(ans)[i] = INTEGER(pch)[i];
    }
    else if (isReal(pch)) {
      for (i = 0; i < n; i++)
          INTEGER(ans)[i] = R_FINITE(REAL(pch)[i]) ?
            REAL(pch)[i] : NA_INTEGER;
    }
    else if (isString(pch)) {
      for (i = 0; i < n; i++) {
          /* New in 2.7.0: negative values indicate Unicode points. */
          INTEGER(ans)[i] = GEstring_to_pch(STRING_ELT(pch, i));
      }
    }
    else if (isLogical(pch)) {/* NA, but not TRUE/FALSE */
      for (i = 0; i < n; i++)
          if(LOGICAL(pch)[i] == NA_LOGICAL) INTEGER(ans)[i] = NA_INTEGER;
          else error(_("only NA allowed in logical plotting symbol"));
    }
    else error(_("invalid plotting symbol"));
    UNPROTECT(1);
    return ans;
}

attribute_hidden
SEXP FixupLty(SEXP lty, int dflt)
{
    int i, n;
    SEXP ans;
    n = length(lty);
    if (n == 0) {
      ans = ScalarInteger(dflt);
    }
    else {
      ans = allocVector(INTSXP, n);
      for (i = 0; i < n; i++)
          INTEGER(ans)[i] = GE_LTYpar(lty, i);
    }
    return ans;
}

attribute_hidden
SEXP FixupLwd(SEXP lwd, double dflt)
{
    int i, n;
    double w;
    SEXP ans = NULL;

    n = length(lwd);
    if (n == 0)
      ans = ScalarReal(dflt);
    else {
      PROTECT(lwd = coerceVector(lwd, REALSXP));
      n = length(lwd);
      ans = allocVector(REALSXP, n);
      for (i = 0; i < n; i++) {
          w = REAL(lwd)[i];
          if (w < 0) w = NA_REAL;
          REAL(ans)[i] = w;

      }
      UNPROTECT(1);
    }
    return ans;
}

static SEXP FixupFont(SEXP font, int dflt)
{
    int i, k, n;
    SEXP ans = R_NilValue;/* -Wall*/
    n = length(font);
    if (n == 0) {
      ans = ScalarInteger(dflt);
    }
    else if (isLogical(font)) {
      ans = allocVector(INTSXP, n);
      for (i = 0; i < n; i++) {
          k = LOGICAL(font)[i];
#ifndef Win32
          if (k < 1 || k > 5) k = NA_INTEGER;
#else
          if (k < 1 || k > 32) k = NA_INTEGER;
#endif
          INTEGER(ans)[i] = k;
      }
    }
    else if (isInteger(font)) {
      ans = allocVector(INTSXP, n);
      for (i = 0; i < n; i++) {
          k = INTEGER(font)[i];
#ifndef Win32
          if (k < 1 || k > 5) k = NA_INTEGER;
#else
          if (k < 1 || k > 32) k = NA_INTEGER;
#endif
          INTEGER(ans)[i] = k;
      }
    }
    else if (isReal(font)) {
      ans = allocVector(INTSXP, n);
      for (i = 0; i < n; i++) {
          k = REAL(font)[i];
#ifndef Win32
          if (k < 1 || k > 5) k = NA_INTEGER;
#else
          if (k < 1 || k > 32) k = NA_INTEGER;
#endif
          INTEGER(ans)[i] = k;
      }
    }
    else error(_("invalid font specification"));
    return ans;
}

attribute_hidden
SEXP FixupCol(SEXP col, unsigned int dflt)
{
    int i, n;
    SEXP ans;
    unsigned int bg = dpptr(GEcurrentDevice())->bg; /* col = 0 */

    n = length(col);
    if (n == 0) {
      PROTECT(ans = ScalarInteger(dflt));
    } else {
      ans = PROTECT(allocVector(INTSXP, n));
      if (isList(col))
          for (i = 0; i < n; i++) {
            INTEGER(ans)[i] = RGBpar3(CAR(col), 0, bg);
            col = CDR(col);
          }
      else
          for (i = 0; i < n; i++)
            INTEGER(ans)[i] = RGBpar3(col, i, bg);
    }
    UNPROTECT(1);
    return ans;
}

static SEXP FixupCex(SEXP cex, double dflt)
{
    SEXP ans;
    int i, n;
    n = length(cex);
    if (n == 0) {
      ans = allocVector(REALSXP, 1);
      if (R_FINITE(dflt) && dflt > 0)
          REAL(ans)[0] = dflt;
      else
          REAL(ans)[0] = NA_REAL;
    }
    else {
      double c;
      ans = allocVector(REALSXP, n);
      if (isReal(cex))
          for (i = 0; i < n; i++) {
            c = REAL(cex)[i];
            if (R_FINITE(c) && c > 0)
                REAL(ans)[i] = c;
            else
                REAL(ans)[i] = NA_REAL;
          }
      else if (isInteger(cex) || isLogical(cex))

          for (i = 0; i < n; i++) {
            c = INTEGER(cex)[i];
            if (c == NA_INTEGER || c <= 0)
                c = NA_REAL;
            REAL(ans)[i] = c;
          }
    }
    return ans;
}

attribute_hidden
SEXP FixupVFont(SEXP vfont) {
    SEXP ans = R_NilValue;
    if (!isNull(vfont)) {
      SEXP vf;
      int typeface, fontindex;
      int minindex, maxindex=0;/* -Wall*/
      int i;
      PROTECT(vf = coerceVector(vfont, INTSXP));
      if (length(vf) != 2)
          error(_("invalid '%s' value"), "vfont");
      typeface = INTEGER(vf)[0];
      if (typeface < 1 || typeface > 8)
          error(_("invalid 'vfont' value [typeface]"));
      /* For each of the typefaces {1..8}, there are several fontindices
         available; how many depends on the typeface.
         The possible combinations are "given" in ./g_fontdb.c
         and also listed in help(Hershey).
       */
      minindex = 1;
      switch (typeface) {
      case 1: /* serif */
          maxindex = 7;     break;
      case 2: /* sans serif */
      case 7: /* serif symbol */
          maxindex = 4;     break;
      case 3: /* script */
          maxindex = 3;     break;
      case 4: /* gothic english */
      case 5: /* gothic german */
      case 6: /* gothic italian */
          maxindex = 1;     break;
      case 8: /* sans serif symbol */
          maxindex = 2;
      }
      fontindex = INTEGER(vf)[1];
      if (fontindex < minindex || fontindex > maxindex)
          error(_("invalid 'vfont' value [typeface = %d, fontindex = %d]"),
              typeface, fontindex);
      ans = allocVector(INTSXP, 2);
      for (i = 0; i < 2; i++) INTEGER(ans)[i] = INTEGER(vf)[i];
      UNPROTECT(1);
    }
    return ans;
}

/* GetTextArg() : extract from call and possibly set text arguments
 *  ("label", col=, cex=, font=)
 *
 * Main purpose: Treat things like  title(main = list("This Title", font= 4))
 *
 * Called from    do_title()  [only, currently]
 */
static void
GetTextArg(SEXP call, SEXP spec, SEXP *ptxt,
         rcolor *pcol, double *pcex, int *pfont)
{
    int i, n, font, colspecd;
    rcolor col;
    double cex;
    SEXP txt, nms;
    PROTECT_INDEX pi;

    txt       = R_NilValue;
    cex       = NA_REAL;
    col       = R_TRANWHITE;
    colspecd = 0;
    font  = NA_INTEGER;
    /* It doesn't look as if this protection is needed */
    PROTECT_WITH_INDEX(txt, &pi);

    switch (TYPEOF(spec)) {
    case LANGSXP:
    case SYMSXP:
      REPROTECT(txt = coerceVector(spec, EXPRSXP), pi);
      break;
    case VECSXP:
      if (length(spec) == 0) {
          *ptxt = R_NilValue;
      }
      else {
          nms = getAttrib(spec, R_NamesSymbol);
          if (nms == R_NilValue){ /* PR#1939 */
             txt = VECTOR_ELT(spec, 0);
             if (TYPEOF(txt) == LANGSXP || TYPEOF(txt) == SYMSXP )
                REPROTECT(txt = coerceVector(txt, EXPRSXP), pi);
             else if (!isExpression(txt))
                REPROTECT(txt = coerceVector(txt, STRSXP), pi);
          } else {
             n = length(nms);
             for (i = 0; i < n; i++) {
            if (!strcmp(CHAR(STRING_ELT(nms, i)), "cex")) {
                cex = asReal(VECTOR_ELT(spec, i));
            }
            else if (!strcmp(CHAR(STRING_ELT(nms, i)), "col")) {
                SEXP colsxp = VECTOR_ELT(spec, i);
                if (!isNAcol(colsxp, 0, LENGTH(colsxp))) {
                  col = asInteger(FixupCol(colsxp, R_TRANWHITE));
                  colspecd = 1;
                }
            }
            else if (!strcmp(CHAR(STRING_ELT(nms, i)), "font")) {
                font = asInteger(FixupFont(VECTOR_ELT(spec, i), NA_INTEGER));
            }
            else if (!strcmp(CHAR(STRING_ELT(nms, i)), "")) {
                txt = VECTOR_ELT(spec, i);
                if (TYPEOF(txt) == LANGSXP || TYPEOF(txt) == SYMSXP)
                  REPROTECT(txt = coerceVector(txt, EXPRSXP), pi);
                else if (!isExpression(txt))
                  REPROTECT(txt = coerceVector(txt, STRSXP), pi);
            }
            else error(_("invalid graphics parameter"));
             }
          }
      }
      break;
    case STRSXP:
    case EXPRSXP:
      txt = spec;
      break;
    default:
      REPROTECT(txt = coerceVector(spec, STRSXP), pi);
      break;
    }
    UNPROTECT(1);
    if (txt != R_NilValue) {
      *ptxt = txt;
      if (R_FINITE(cex))       *pcex       = cex;
      if (colspecd)              *pcol     = col;
      if (font != NA_INTEGER)  *pfont      = font;
    }
}/* GetTextArg */


    /* GRAPHICS FUNCTION ENTRY POINTS */


SEXP attribute_hidden do_plot_new(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* plot.new() - create a new plot "frame" */

    pGEDevDesc dd;

    checkArity(op, args);

    dd = GEcurrentDevice();
    /*
     * If user is prompted before new page, user has opportunity
     * to kill current device.  GNewPlot returns (potentially new)
     * current device.
     */
    dd = GNewPlot(GRecording(call, dd));

    dpptr(dd)->xlog = gpptr(dd)->xlog = FALSE;
    dpptr(dd)->ylog = gpptr(dd)->ylog = FALSE;

    GScale(0.0, 1.0, 1, dd);
    GScale(0.0, 1.0, 2, dd);
    GMapWin2Fig(dd);
    GSetState(1, dd);

    if (GRecording(call, dd))
      GErecordGraphicOperation(op, args, dd);
    return R_NilValue;
}


/*
 *  SYNOPSIS
 *
 *    plot.window(xlim, ylim, log="", asp=NA)
 *
 *  DESCRIPTION
 *
 *    This function sets up the world coordinates for a graphics
 *    window.      Note that if asp is a finite positive value then
 *    the window is set up so that one data unit in the y direction
 *    is equal in length to one data unit in the x direction divided
 *    by asp.
 *
 *    The special case asp == 1 produces plots where distances
 *    between points are represented accurately on screen.
 *
 *  NOTE
 *
 *    The use of asp can have weird effects when axis is an
 *    interpreted function.  It has to be internal so that the
 *    full computation is captured in the display list.
 */

SEXP attribute_hidden do_plot_window(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP xlim, ylim, logarg;
    double asp, xmin, xmax, ymin, ymax;
    Rboolean logscale;
    const char *p;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    if (length(args) < 3)
      error(_("at least 3 arguments required"));

    xlim = CAR(args);
    if (!isNumeric(xlim) || LENGTH(xlim) != 2)
      error(_("invalid '%s' value"), "xlim");
    args = CDR(args);

    ylim = CAR(args);
    if (!isNumeric(ylim) || LENGTH(ylim) != 2)
      error(_("invalid '%s' value"), "ylim");
    args = CDR(args);

    logscale = FALSE;
    logarg = CAR(args);
    if (!isString(logarg))
      error(_("\"log=\" specification must be character"));
    p = CHAR(STRING_ELT(logarg, 0));
    while (*p) {
      switch (*p) {
      case 'x':
          dpptr(dd)->xlog = gpptr(dd)->xlog = logscale = TRUE;
          break;
      case 'y':
          dpptr(dd)->ylog = gpptr(dd)->ylog = logscale = TRUE;
          break;
      default:
          error(_("invalid \"log=%s\" specification"), p);
      }
      p++;
    }
    args = CDR(args);

    asp = (logscale) ? NA_REAL : asReal(CAR(args));;
    args = CDR(args);

    /* This reads [xy]axs and lab, used in GScale */
    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    if (isInteger(xlim)) {
      if (INTEGER(xlim)[0] == NA_INTEGER || INTEGER(xlim)[1] == NA_INTEGER)
          error(_("NAs not allowed in 'xlim'"));
      xmin = INTEGER(xlim)[0];
      xmax = INTEGER(xlim)[1];
    }
    else {
      if (!R_FINITE(REAL(xlim)[0]) || !R_FINITE(REAL(xlim)[1]))
          error(_("need finite 'xlim' values"));
      xmin = REAL(xlim)[0];
      xmax = REAL(xlim)[1];
    }
    if (isInteger(ylim)) {
      if (INTEGER(ylim)[0] == NA_INTEGER || INTEGER(ylim)[1] == NA_INTEGER)
          error(_("NAs not allowed in 'ylim'"));
      ymin = INTEGER(ylim)[0];
      ymax = INTEGER(ylim)[1];
    }
    else {
      if (!R_FINITE(REAL(ylim)[0]) || !R_FINITE(REAL(ylim)[1]))
          error(_("need finite 'ylim' values"));
      ymin = REAL(ylim)[0];
      ymax = REAL(ylim)[1];
    }
    if ((dpptr(dd)->xlog && (xmin < 0 || xmax < 0)) ||
       (dpptr(dd)->ylog && (ymin < 0 || ymax < 0)))
          error(_("Logarithmic axis must have positive limits"));

    if (R_FINITE(asp) && asp > 0) {
      double pin1, pin2, scale, xdelta, ydelta, xscale, yscale, xadd, yadd;
      pin1 = GConvertXUnits(1.0, NPC, INCHES, dd);
      pin2 = GConvertYUnits(1.0, NPC, INCHES, dd);
      xdelta = fabs(xmax - xmin) / asp;
      ydelta = fabs(ymax - ymin);
      if(xdelta == 0.0 && ydelta == 0.0) {
          /* We really do mean zero: small non-zero values work.
             Mimic the behaviour of GScale for the x axis. */
          xadd = yadd = ((xmin == 0.0) ? 1 : 0.4) * asp;
          xadd *= asp;
      } else {
          xscale = pin1 / xdelta;
          yscale = pin2 / ydelta;
          scale = (xscale < yscale) ? xscale : yscale;
          xadd = .5 * (pin1 / scale - xdelta) * asp;
          yadd = .5 * (pin2 / scale - ydelta);
      }
      if(xmax < xmin) xadd *= -1;
      if(ymax < ymin) yadd *= -1;
      GScale(xmin - xadd, xmax + xadd, 1, dd);
      GScale(ymin - yadd, ymax + yadd, 2, dd);
    }
    else { /* asp <= 0 or not finite -- includes logscale ! */
      GScale(xmin, xmax, 1, dd);
      GScale(ymin, ymax, 2, dd);
    }
    /* GScale set the [xy]axp parameters */
    GMapWin2Fig(dd);
    GRestorePars(dd);
    /* This has now clobbered the Rf_ggptr settings for coord system */

    /* NOTE: the operation is only recorded if there was no "error" */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}

static void GetAxisLimits(double left, double right, double *low, double *high)
{
/*    Called from do_axis()   such as
 *    GetAxisLimits(gpptr(dd)->usr[0], gpptr(dd)->usr[1], &low, &high)
 *
 *    Computes  *low < left, right < *high  (even if left=right)
 */
    double eps;
    if (left > right) {/* swap */
      eps = left; left = right; right = eps;
    }
    eps = right - left;
    if (eps == 0.)
      eps = 0.5 * FLT_EPSILON;
    else
      eps *= FLT_EPSILON;
    *low = left - eps;
    *high = right + eps;
}


/* axis(side, at, labels, ...) */

SEXP attribute_hidden labelformat(SEXP labels)
{
    /* format(labels): i.e. from numbers to strings */
    SEXP ans = R_NilValue;/* -Wall*/
    int i, n, w, d, e, wi, di, ei;
    const char *strp;
    n = length(labels);
    R_print.digits = 7;/* maximally 7 digits -- ``burnt in'';
                    S-PLUS <= 5.x has about 6
                    (but really uses single precision..) */
    switch(TYPEOF(labels)) {
    case LGLSXP:
      PROTECT(ans = allocVector(STRSXP, n));
      for (i = 0; i < n; i++) {
          strp = EncodeLogical(LOGICAL(labels)[i], 0);
          SET_STRING_ELT(ans, i, mkChar(strp));
      }
      UNPROTECT(1);
      break;
    case INTSXP:
      PROTECT(ans = allocVector(STRSXP, n));
      for (i = 0; i < n; i++) {
          strp = EncodeInteger(INTEGER(labels)[i], 0);
          SET_STRING_ELT(ans, i, mkChar(strp));
      }
      UNPROTECT(1);
      break;
    case REALSXP:
      formatReal(REAL(labels), n, &w, &d, &e, 0);
      PROTECT(ans = allocVector(STRSXP, n));
      for (i = 0; i < n; i++) {
          strp = EncodeReal(REAL(labels)[i], 0, d, e, OutDec);
          SET_STRING_ELT(ans, i, mkChar(strp));
      }
      UNPROTECT(1);
      break;
    case CPLXSXP:
      formatComplex(COMPLEX(labels), n, &w, &d, &e, &wi, &di, &ei, 0);
      PROTECT(ans = allocVector(STRSXP, n));
      for (i = 0; i < n; i++) {
          strp = EncodeComplex(COMPLEX(labels)[i], 0, d, e, 0, di, ei,
                         OutDec);
          SET_STRING_ELT(ans, i, mkChar(strp));
      }
      UNPROTECT(1);
      break;
    case STRSXP:
      PROTECT(ans = allocVector(STRSXP, n));
      for (i = 0; i < n; i++) {
          SET_STRING_ELT(ans, i, STRING_ELT(labels, i));
      }
      UNPROTECT(1);
      break;
    default:
      error(_("invalid type for axis labels"));
    }
    return ans;
}

SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
{
/*    Create an  'at = ...' vector for  axis(.) / do_axis,
 *    i.e., the vector of tick mark locations,
 *    when none has been specified (= default).
 *
 *    axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks
 *             {unless in log case, where nint \in {1,2,3 ; -1,-2,....}
 *              and the `nint' argument is used.}

 *    The resulting REAL vector must have length >= 1, ideally >= 2
 */
    SEXP at = R_NilValue;/* -Wall*/
    double umin, umax, dn, rng, small;
    int i, n, ne;
    if (!logflag || axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */
      n = fabs(axp[2]) + 0.25;/* >= 0 */
      dn = imax2(1, n);
      rng = axp[1] - axp[0];
      small = fabs(rng)/(100.*dn);
      at = allocVector(REALSXP, n + 1);
      for (i = 0; i <= n; i++) {
          REAL(at)[i] = axp[0] + (i / dn) * rng;
          if (fabs(REAL(at)[i]) < small)
            REAL(at)[i] = 0;
      }
    }
    else { /* ------ log axis ----- */
      Rboolean reversed = FALSE;

      n = (axp[2] + 0.5);
      /* {xy}axp[2] for 'log': GLpretty() [./graphics.c] sets
         n < 0: very small scale ==> linear axis, above, or
         n = 1,2,3.  see switch() below */
      umin = usr[0];
      umax = usr[1];
      if (umin > umax) {
          reversed = (axp[0] > axp[1]);
          if (reversed) {
            /* have *reversed* log axis -- whereas
             * the switch(n) { .. } below assumes *increasing* values
             * --> reverse axis direction here, and reverse back at end */
            umin = usr[1];
            umax = usr[0];
            dn = axp[0]; axp[0] = axp[1]; axp[1] = dn;
          }
          else {
            /* can the following still happen... ? */
            warning("CreateAtVector \"log\"(from axis()): "
                  "usr[0] = %g > %g = usr[1] !", umin, umax);
          }
      }

      dn = axp[0];
      if (dn < DBL_MIN) {/* was 1e-300; now seems too cautious */
          warning("CreateAtVector \"log\"(from axis()): axp[0] = %g !", dn);
          if (dn <= 0) /* real trouble (once for Solaris) later on */
            error("CreateAtVector [log-axis()]: axp[0] = %g < 0!", dn);
      }

      /* You get the 3 cases below by
       *  for (y in 1e-5*c(1,2,8))  plot(y, log = "y")
       */
      switch(n) {
      case 1: /* large range: 1      * 10^k */
          i = floor(log10(axp[1])) - ceil(log10(axp[0])) + 0.25;
          ne = i / nint + 1;
          if (ne < 1)
            error("log - axis(), 'at' creation, _LARGE_ range: "
                  "ne = %d <= 0 !!\n"
                  "\t axp[0:1]=(%g,%g) ==> i = %d;    nint = %d",
                  ne, axp[0],axp[1], i, nint);
          rng = pow(10., (double)ne);/* >= 10 */
          n = 0;
          while (dn < umax) {
            n++;
            dn *= rng;
          }
          if (!n)
            error("log - axis(), 'at' creation, _LARGE_ range: "
                  "invalid {xy}axp or par; nint=%d\n"
                  "      axp[0:1]=(%g,%g), usr[0:1]=(%g,%g); i=%d, ni=%d",
                  nint, axp[0],axp[1], umin,umax, i,ne);
          at = allocVector(REALSXP, n);
          dn = axp[0];
          n = 0;
          while (dn < umax) {
            REAL(at)[n++] = dn;
            dn *= rng;
          }
          break;

      case 2: /* medium range:  1, 5        * 10^k */
          n = 0;
          if (0.5 * dn >= umin) n++;
          for (;;) {
            if (dn > umax) break;         n++;
            if (5 * dn > umax) break;     n++;
            dn *= 10;
          }
          if (!n)
            error("log - axis(), 'at' creation, _MEDIUM_ range: "
                  "invalid {xy}axp or par;\n"
                  "      axp[0]= %g, usr[0:1]=(%g,%g)",
                  axp[0], umin,umax);

          at = allocVector(REALSXP, n);
          dn = axp[0];
          n = 0;
          if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
          for (;;) {
            if (dn > umax) break;         REAL(at)[n++] = dn;
            if (5 * dn > umax) break;     REAL(at)[n++] = 5 * dn;
            dn *= 10;
          }
          break;

      case 3: /* small range:  1,2,5,10 * 10^k */
          n = 0;
          if (0.2 * dn >= umin) n++;
          if (0.5 * dn >= umin) n++;
          for (;;) {
            if (dn > umax) break;         n++;
            if (2 * dn > umax) break;     n++;
            if (5 * dn > umax) break;     n++;
            dn *= 10;
          }
          if (!n)
            error("log - axis(), 'at' creation, _SMALL_ range: "
                  "invalid {xy}axp or par;\n"
                  "      axp[0]= %g, usr[0:1]=(%g,%g)",
                  axp[0], umin,umax);
          at = allocVector(REALSXP, n);
          dn = axp[0];
          n = 0;
          if (0.2 * dn >= umin) REAL(at)[n++] = 0.2 * dn;
          if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
          for (;;) {
            if (dn > umax) break;         REAL(at)[n++] = dn;
            if (2 * dn > umax) break;     REAL(at)[n++] = 2 * dn;
            if (5 * dn > umax) break;     REAL(at)[n++] = 5 * dn;
            dn *= 10;
          }
          break;
      default:
          error("log - axis(), 'at' creation: INVALID {xy}axp[3] = %g",
              axp[2]);
      }

      if (reversed) {/* reverse back again - last assignment was at[n++]= . */
          for (i = 0; i < n/2; i++) { /* swap( at[i], at[n-i-1] ) : */
            dn = REAL(at)[i];
            REAL(at)[i] = REAL(at)[n-i-1];
            REAL(at)[n-i-1] = dn;
          }
      }
    } /* linear / log */
    return at;
}

static double ComputePAdjValue(double padj, int side, int las)
{
    if (!R_FINITE(padj)) {
    switch(las) {
    case 0:/* parallel to axis */
      padj = 0.0; break;
    case 1:/* horizontal */
      switch(side) {
      case 1:
      case 3: padj = 0.0; break;
      case 2:
      case 4: padj = 0.5; break;
      }
      break;
    case 2:/* perpendicular to axis */
      padj = 0.5; break;
    case 3:/* vertical */
      switch(side) {
      case 1:
      case 3: padj = 0.5; break;
      case 2:
      case 4: padj = 0.0; break;
      }
      break;
    }
    }
    return padj;
}

static void getxlimits(double *x, pGEDevDesc dd) {
    /*
     * xpd = 0 means clip to current plot region
     * xpd = 1 means clip to current figure region
     * xpd = 2 means clip to device region
     */
    switch (gpptr(dd)->xpd) {
    case 0:
      x[0] = gpptr(dd)->usr[0];
      x[1] = gpptr(dd)->usr[1];
      break;
    case 1:
      x[0] = GConvertX(0, NFC, USER, dd);
      x[1] = GConvertX(1, NFC, USER, dd);
      break;
    case 2:
      x[0] = GConvertX(0, NDC, USER, dd);
      x[1] = GConvertX(1, NDC, USER, dd);
      break;
    }
}

static void getylimits(double *y, pGEDevDesc dd) {
    switch (gpptr(dd)->xpd) {
    case 0:
      y[0] = gpptr(dd)->usr[2];
      y[1] = gpptr(dd)->usr[3];
      break;
    case 1:
      y[0] = GConvertY(0, NFC, USER, dd);
      y[1] = GConvertY(1, NFC, USER, dd);
      break;
    case 2:
      y[0] = GConvertY(0, NDC, USER, dd);
      y[1] = GConvertY(1, NDC, USER, dd);
      break;
    }
}

SEXP attribute_hidden do_axis(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* axis(side, at, labels, tick, line, pos,
     *          outer, font, lty, lwd, col, padj, ...) */

    SEXP at, lab, padj;
    int font, lty, npadj;
    rcolor col;
    int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
    int istart, iend, incr;
    Rboolean dolabels, doticks, logflag = FALSE;
    Rboolean create_at;
    double x, y, temp, tnew, tlast;
    double axp[3], usr[2], limits[2];
    double gap, labw, low, high, line, pos, lwd, hadj;
    double axis_base, axis_tick, axis_lab, axis_low, axis_high;

    SEXP originalArgs = args, label;
    pGEDevDesc dd = GEcurrentDevice();

    /* Arity Check */
    /* This is a builtin function, so it should always have */
    /* the correct arity, but it doesn't hurt to be defensive. */

    if (length(args) < 12)
      error(_("too few arguments"));
    GCheckState(dd);

    /* Required argument: "side" */
    /* Which side of the plot the axis is to appear on. */
    /* side = 1 | 2 | 3 | 4. */

    side = asInteger(CAR(args));
    if (side < 1 || side > 4)
      error(_("invalid axis number %d"), side);
    args = CDR(args);

    /* Required argument: "at" */
    /* This gives the tick-label locations. */
    /* Note that these are coerced to the correct type below. */

    at = CAR(args); args = CDR(args);

    /* Required argument: "labels" */
    /* Labels can be a logical, indicating whether or not */
    /* to label the axis; or it can be a vector of character */
    /* strings or expressions which give the labels explicitly. */
    /* The expressions are used to set mathematical labelling. */

    dolabels = TRUE;
    lab = CAR(args);
    if (isLogical(lab) && length(lab) > 0) {
      i = asLogical(lab);
      if (i == 0 || i == NA_LOGICAL)
          dolabels = FALSE;
      PROTECT(lab = R_NilValue);
    } else if (TYPEOF(lab) == LANGSXP || TYPEOF(lab) == SYMSXP) {
      PROTECT(lab = coerceVector(lab, EXPRSXP));
    } else if (isExpression(lab)) {
      PROTECT(lab);
    } else {
      PROTECT(lab = coerceVector(lab, STRSXP));
    }
    args = CDR(args);

    /* Required argument: "tick" */
    /* This indicates whether or not ticks and the axis line */
    /* should be plotted: TRUE => show, FALSE => don't show. */

    doticks = asLogical(CAR(args));
    doticks = (doticks == NA_LOGICAL) ? TRUE : (Rboolean) doticks;
    args = CDR(args);

    /* Optional argument: "line" */

    /* Specifies an offset outward from the plot for the axis.
     * The values in the par value "mgp" are interpreted
     * relative to this value. */
    line = asReal(CAR(args));
    if (!R_FINITE(line)) {
      /* Except that here mgp values are not relative to themselves */
      line = gpptr(dd)->mgp[2];
      lineoff = line;
    }
    args = CDR(args);

    /* Optional argument: "pos" */
    /* Specifies a user coordinate at which the axis should be drawn. */
    /* This overrides the value of "line".  Again the "mgp" par values */
    /* are interpreted relative to this value. */

    pos = asReal(CAR(args));
    if (!R_FINITE(pos)) pos = NA_REAL; else lineoff = 0;
    args = CDR(args);

    /* Optional argument: "outer" */
    /* Should the axis be drawn in the outer margin. */
    /* This only affects the computation of axis_base. */

    outer = asLogical(CAR(args));
    if (outer == NA_LOGICAL || outer == 0)
      outer = NPC;
    else
      outer = NIC;
    args = CDR(args);

    /* Optional argument: "font" */
    font = asInteger(FixupFont(CAR(args), NA_INTEGER));
    args = CDR(args);

    /* Optional argument: "lty" */
    lty = asInteger(FixupLty(CAR(args), NA_INTEGER));
    args = CDR(args);

    /* Optional argument: "lwd" */
    lwd = asReal(FixupLwd(CAR(args), 1));
    args = CDR(args);

    /* Optional argument: "col" */
    col = asInteger(FixupCol(CAR(args), gpptr(dd)->fg));
    args = CDR(args);

    /* Optional argument: "hadj" */
    if (length(CAR(args)) != 1)
      error(_("'hadj' must be of length one"));
    hadj = asReal(CAR(args));
    args = CDR(args);

    /* Optional argument: "padj" */
    PROTECT(padj = coerceVector(CAR(args), REALSXP));
    npadj = length(padj);
    if (npadj <= 0) error(_("zero length 'padj' specified"));

    /* Now we process all the remaining inline par values:
       we need to do it now as x/yaxp are retrieved next.
       That will set gpptr, so we update that first - do_plotwindow
       clobbered the gpptr settings. */
    GSavePars(dd);
    gpptr(dd)->xaxp[0] = dpptr(dd)->xaxp[0];
    gpptr(dd)->xaxp[1] = dpptr(dd)->xaxp[1];
    gpptr(dd)->xaxp[2] = dpptr(dd)->xaxp[2];
    gpptr(dd)->yaxp[0] = dpptr(dd)->yaxp[0];
    gpptr(dd)->yaxp[1] = dpptr(dd)->yaxp[1];
    gpptr(dd)->yaxp[2] = dpptr(dd)->yaxp[2];
    ProcessInlinePars(args, dd, call);

    /* Retrieve relevant "par" values. */

    switch(side) {
    case 1:
    case 3:
      axp[0] = gpptr(dd)->xaxp[0];
      axp[1] = gpptr(dd)->xaxp[1];
      axp[2] = gpptr(dd)->xaxp[2];
      usr[0] = dpptr(dd)->usr[0];
      usr[1] = dpptr(dd)->usr[1];
      logflag = dpptr(dd)->xlog;
      nint = dpptr(dd)->lab[0];
      break;
    case 2:
    case 4:
      axp[0] = gpptr(dd)->yaxp[0];
      axp[1] = gpptr(dd)->yaxp[1];
      axp[2] = gpptr(dd)->yaxp[2];
      usr[0] = dpptr(dd)->usr[2];
      usr[1] = dpptr(dd)->usr[3];
      logflag = dpptr(dd)->ylog;
      nint = dpptr(dd)->lab[1];
      break;
    }

    /* Determine the tickmark positions.  Note that these may fall */
    /* outside the plot window. We will clip them in the code below. */

    create_at = isNull(at);
    if (create_at) {
      PROTECT(at = CreateAtVector(axp, usr, nint, logflag));
    }
    else {
      if (isReal(at)) PROTECT(at = duplicate(at));
      else PROTECT(at = coerceVector(at, REALSXP));
    }
    n = length(at);

    /* Check/setup the tick labels.  This can mean using user-specified */
    /* labels, or encoding the "at" positions as strings. */

    if (dolabels) {
      if (length(lab) == 0)
          lab = labelformat(at);
      else {
          if (create_at)
            error(_("'labels' is supplied and not 'at'"));
          if (!isExpression(lab)) lab = labelformat(lab);
      }
      if (length(at) != length(lab))
          error(_("'at' and 'labels' lengths differ, %d != %d"),
                  length(at), length(lab));
    }
    PROTECT(lab);

    /* Check there are no NA, Inf or -Inf values for tick positions. */
    /* The code here is long-winded.  Couldn't we just inline things */
    /* below.  Hmmm - we need the min and max of the finite values ... */

    ind = (int *) R_alloc(n, sizeof(int));
    for(i = 0; i < n; i++) ind[i] = i;
    rsort_with_index(REAL(at), ind, n);
    ntmp = 0;
    for(i = 0; i < n; i++) {
      if(R_FINITE(REAL(at)[i])) ntmp = i+1;
    }
    if (n > 0 && ntmp == 0)
      error(_("no locations are finite"));
    n = ntmp;
    
    /* Ok, all systems are "GO".  Let's get to it. */

    /* At this point we know the value of "xaxt" and "yaxt",
     * so we test to see whether the relevant one is "n".
     * If it is, we just bail out at this point. */

    if ((n == 0) ||
        ((side == 1 || side == 3) && gpptr(dd)->xaxt == 'n') ||
      ((side == 2 || side == 4) && gpptr(dd)->yaxt == 'n')) {
      GRestorePars(dd);
      UNPROTECT(4);
      return R_NilValue;
    }


    /* no! we do allow an `lty' argument -- will not be used often though
     *      gpptr(dd)->lty = LTY_SOLID; */
    gpptr(dd)->lty = lty;
    gpptr(dd)->lwd = lwd;
    gpptr(dd)->adj = R_FINITE(hadj) ? hadj : 0.5;
    gpptr(dd)->font = (font == NA_INTEGER)? gpptr(dd)->fontaxis : font;
    gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cexaxis;
    /* no!   col = gpptr(dd)->col; */

    /* Draw the axis */
    GMode(1, dd);
    switch (side) {
    case 1: /*--- x-axis -- horizontal --- */
    case 3:
        /* First set the clipping limits */
        getxlimits(limits, dd);
        /* Now override par("xpd") and force clipping to device region. */
        gpptr(dd)->xpd = 2;        
      GetAxisLimits(limits[0], limits[1], &low, &high);
      axis_low  = GConvertX(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
      axis_high = GConvertX(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
      if (side == 1) {
          if (R_FINITE(pos))
            axis_base = GConvertY(pos, USER, NFC, dd);
          else
            axis_base = GConvertY(0.0, outer, NFC, dd)
                - GConvertYUnits(line, LINES, NFC, dd);
          if (R_FINITE(gpptr(dd)->tck)) {
            double len, xu, yu;
            if(gpptr(dd)->tck > 0.5)
                len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
            else {
                xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                xu = (fabs(xu) < fabs(yu)) ? xu : yu;
                len = GConvertYUnits(xu, INCHES, NFC, dd);
            }
            axis_tick = axis_base + len;

          } else
            axis_tick = axis_base +
                  GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
      }
      else {
          if (R_FINITE(pos))
            axis_base = GConvertY(pos, USER, NFC, dd);
          else
            axis_base =  GConvertY(1.0, outer, NFC, dd)
                + GConvertYUnits(line, LINES, NFC, dd);
          if (R_FINITE(gpptr(dd)->tck)) {
            double len, xu, yu;
            if(gpptr(dd)->tck > 0.5)
                len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
            else {
                xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                xu = (fabs(xu) < fabs(yu)) ? xu : yu;
                len = GConvertYUnits(xu, INCHES, NFC, dd);
            }
            axis_tick = axis_base - len;
          } else
            axis_tick = axis_base -
                GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
      }
      if (doticks) {
          gpptr(dd)->col = col;/*was fg */
          GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
          for (i = 0; i < n; i++) {
            x = REAL(at)[i];
            if (low <= x && x <= high) {
                x = GConvertX(x, USER, NFC, dd);
                GLine(x, axis_base, x, axis_tick, NFC, dd);
            }
          }
      }
      /* Tickmark labels. */
      gpptr(dd)->col = gpptr(dd)->colaxis;
      gap = GStrWidth("m", -1, NFC, dd);  /* FIXUP x/y distance */
      tlast = -1.0;
      if (!R_FINITE(hadj)) {
          if (gpptr(dd)->las == 2 || gpptr(dd)->las == 3) {
            gpptr(dd)->adj = (side == 1) ? 1 : 0;
          }
          else gpptr(dd)->adj = 0.5;
      }
      if (side == 1) {
          axis_lab = - axis_base
            + GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
            + GConvertY(0.0, NPC, NFC, dd);
      }
      else { /* side == 3 */
          axis_lab = axis_base
            + GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
            - GConvertY(1.0, NPC, NFC, dd);
      }
      axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);

      /* The order of processing is important here. */
      /* We must ensure that the labels are drawn left-to-right. */
      /* The logic here is getting way too convoluted. */
      /* This needs a serious rewrite. */

      if (gpptr(dd)->usr[0] > gpptr(dd)->usr[1]) {
          istart = n - 1;
          iend = -1;
          incr = -1;
      }
      else {
          istart = 0;
          iend = n;
          incr = 1;
      }
      for (i = istart; i != iend; i += incr) {
          double padjval = REAL(padj)[i%npadj];
          padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
          x = REAL(at)[i];
          if (!R_FINITE(x)) continue;
          temp = GConvertX(x, USER, NFC, dd);
          if (dolabels) {
            /* Clip tick labels to user coordinates. */
            if (x > low && x < high) {
                if (isExpression(lab)) {
                  GMMathText(VECTOR_ELT(lab, ind[i]), side,
                           axis_lab, 0, x, gpptr(dd)->las,
                           padjval, dd);
                }
                else {
                  label = STRING_ELT(lab, ind[i]);
                  if(label != NA_STRING) {
                      const char *ss = CHAR(label);
                      labw = GStrWidth(ss, 0, NFC, dd);
                      tnew = temp - 0.5 * labw;
                      /* Check room for perpendicular labels. */
                      if (gpptr(dd)->las == 2 ||
                        gpptr(dd)->las == 3 ||
                        tnew - tlast >= gap) {
                        GMtext(ss, getCharCE(label),
                               side, axis_lab, 0, x,
                               gpptr(dd)->las, padjval, dd);
                        tlast = temp + 0.5 *labw;
                      }
                  }
                }
            }
          }
      }
      break;

    case 2: /*--- y-axis -- vertical --- */
    case 4:
        /* First set the clipping limits */
        getylimits(limits, dd);
        /* Now override par("xpd") and force clipping to device region. */
        gpptr(dd)->xpd = 2;      
      GetAxisLimits(limits[0], limits[1], &low, &high);
      axis_low = GConvertY(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
      axis_high = GConvertY(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
      if (side == 2) {
          if (R_FINITE(pos))
            axis_base = GConvertX(pos, USER, NFC, dd);
          else
            axis_base =  GConvertX(0.0, outer, NFC, dd)
                - GConvertXUnits(line, LINES, NFC, dd);
          if (R_FINITE(gpptr(dd)->tck)) {
            double len, xu, yu;
            if(gpptr(dd)->tck > 0.5)
                len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
            else {
                xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                xu = (fabs(xu) < fabs(yu)) ? xu : yu;
                len = GConvertXUnits(xu, INCHES, NFC, dd);
            }
            axis_tick = axis_base + len;
          } else
            axis_tick = axis_base +
                GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
      }
      else {
          if (R_FINITE(pos))
            axis_base = GConvertX(pos, USER, NFC, dd);
          else
            axis_base =  GConvertX(1.0, outer, NFC, dd)
                + GConvertXUnits(line, LINES, NFC, dd);
          if (R_FINITE(gpptr(dd)->tck)) {
            double len, xu, yu;
            if(gpptr(dd)->tck > 0.5)
                len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
            else {
                xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
                xu = (fabs(xu) < fabs(yu)) ? xu : yu;
                len = GConvertXUnits(xu, INCHES, NFC, dd);
            }
            axis_tick = axis_base - len;
          } else
            axis_tick = axis_base -
                GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
      }
      if (doticks) {
          gpptr(dd)->col = col;/*was fg */
          GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
          for (i = 0; i < n; i++) {
            y = REAL(at)[i];
            if (low <= y && y <= high) {
                y = GConvertY(y, USER, NFC, dd);
                GLine(axis_base, y, axis_tick, y, NFC, dd);
            }
          }
      }
      /* Tickmark labels. */
      gpptr(dd)->col = gpptr(dd)->colaxis;
      gap = GStrWidth("m", CE_ANY, INCHES, dd);
      gap = GConvertYUnits(gap, INCHES, NFC, dd);
      tlast = -1.0;
      if (!R_FINITE(hadj)) {
          if (gpptr(dd)->las == 1 || gpptr(dd)->las == 2) {
            gpptr(dd)->adj = (side == 2) ? 1 : 0;
          }
          else gpptr(dd)->adj = 0.5;
      }
      if (side == 2) {
          axis_lab = - axis_base
            + GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
            + GConvertX(0.0, NPC, NFC, dd);
      }
      else { /* side == 4 */
          axis_lab = axis_base
            + GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
            - GConvertX(1.0, NPC, NFC, dd);
      }
      axis_lab = GConvertXUnits(axis_lab, NFC, LINES, dd);

      /* The order of processing is important here. */
      /* We must ensure that the labels are drawn left-to-right. */
      /* The logic here is getting way too convoluted. */
      /* This needs a serious rewrite. */

      if (gpptr(dd)->usr[2] > gpptr(dd)->usr[3]) {
          istart = n - 1;
          iend = -1;
          incr = -1;
      }
      else {
          istart = 0;
          iend = n;
          incr = 1;
      }
      for (i = istart; i != iend; i += incr) {
          double padjval = REAL(padj)[i%npadj];
          padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
          y = REAL(at)[i];
          if (!R_FINITE(y)) continue;
          temp = GConvertY(y, USER, NFC, dd);
          if (dolabels) {
            /* Clip tick labels to user coordinates. */
            if (y > low && y < high) {
                if (isExpression(lab)) {
                  GMMathText(VECTOR_ELT(lab, ind[i]), side,
                           axis_lab, 0, y, gpptr(dd)->las,
                           padjval, dd);
                }
                else {
                  label = STRING_ELT(lab, ind[i]);
                  if(label != NA_STRING) {
                      const char *ss = CHAR(label);
                      labw = GStrWidth(ss, getCharCE(label), INCHES, dd);
                      labw = GConvertYUnits(labw, INCHES, NFC, dd);
                      tnew = temp - 0.5 * labw;
                      /* Check room for perpendicular labels. */
                      if (gpptr(dd)->las == 1 ||
                        gpptr(dd)->las == 2 ||
                        tnew - tlast >= gap) {
                        GMtext(ss, getCharCE(label),
                               side, axis_lab, 0, y,
                               gpptr(dd)->las, padjval, dd);
                        tlast = temp + 0.5 *labw;
                      }
                  }
                }
            }
          }
      }
      break;
    } /* end  switch(side, ..) */
    GMode(0, dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    UNPROTECT(4); /* lab, at, lab, padj again */
    return at;
}/* do_axis */

#ifndef HAVE_HYPOT
# define hypot pythag
#endif

SEXP attribute_hidden do_plot_xy(SEXP call, SEXP op, SEXP args, SEXP env)
{
/*    plot.xy(xy, type, pch, lty, col, bg, cex, lwd, ...)

 *    plot points or lines of various types
 */
    SEXP sxy, sx, sy, pch, cex, col, bg, lty, lwd;
    double *x, *y, xold, yold, xx, yy, thiscex, thislwd;
    int i, n, npch, ncex, ncol, nbg, nlwd, type=0, start=0, thispch;
    rcolor thiscol, thisbg;
    void *vmax = NULL /* -Wall */;

    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    /* Basic Checks */
    GCheckState(dd);
    if (length(args) < 7)
      error(_("too few arguments"));

    /* Required Arguments */
#define PLOT_XY_DEALING(subname)                      \
    sx = R_NilValue;          /* -Wall */             \
    sy = R_NilValue;          /* -Wall */             \
    sxy = CAR(args);                                  \
    if (isNewList(sxy) && length(sxy) >= 2) {               \
      internalTypeCheck(call, sx = VECTOR_ELT(sxy, 0), REALSXP); \
      internalTypeCheck(call, sy = VECTOR_ELT(sxy, 1), REALSXP); \
    }                                           \
    else if (isList(sxy) && length(sxy) >= 2) {             \
      internalTypeCheck(call, sx = CAR(sxy), REALSXP);      \
      internalTypeCheck(call, sy = CADR(sxy), REALSXP);     \
    }                                           \
    else                                        \
      error(_("invalid plotting structure"));   \
    if (LENGTH(sx) != LENGTH(sy))                     \
      error(_("'x' and 'y' lengths differ in %s()"), subname);\
    n = LENGTH(sx);                                   \
    args = CDR(args)

    PLOT_XY_DEALING("plot.xy");

    if (isNull(CAR(args))) type = 'p';
    else {
      if (isString(CAR(args)) && LENGTH(CAR(args)) == 1 &&
          LENGTH(pch = STRING_ELT(CAR(args), 0)) >= 1) {
          if(LENGTH(pch) > 1)
            warning(_("plot type '%s' will be truncated to first character"),
                  CHAR(pch));
          type = CHAR(pch)[0];
      }
      else error(_("invalid plot type"));
    }
    args = CDR(args);

    PROTECT(pch = FixupPch(CAR(args), gpptr(dd)->pch));
    npch = length(pch);
    args = CDR(args);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
    args = CDR(args);

    /* Default col was NA_INTEGER (0x80000000) which was interpreted
       as zero (black) or "don't draw" depending on line/rect/circle
       situation. Now we set the default to zero and don't plot at all
       if col==NA.

       FIXME: bg needs similar change, but that requires changes to
       the specific drivers. */

    PROTECT(col = FixupCol(CAR(args), 0));            args = CDR(args);
    ncol = LENGTH(col);

    PROTECT(bg = FixupCol(CAR(args), R_TRANWHITE));   args = CDR(args);
    nbg = LENGTH(bg);

    PROTECT(cex = FixupCex(CAR(args), 1.0));          args = CDR(args);
    ncex = LENGTH(cex);

    PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd)); args = CDR(args);
    nlwd = LENGTH(lwd);

    /* Miscellaneous Graphical Parameters */
    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    x = REAL(sx);
    y = REAL(sy);

    if (INTEGER(lty)[0] != NA_INTEGER)
      gpptr(dd)->lty = INTEGER(lty)[0];
    if (R_FINITE( (thislwd = REAL(lwd)[0]) ))
      gpptr(dd)->lwd = thislwd; /* but do recycle for "p" etc */

    GMode(1, dd);

    /* Line drawing :*/
    switch(type) {
    case 'l':
    case 'o':
      /* lines and overplotted lines and points */
      gpptr(dd)->col = INTEGER(col)[0];
      xold = NA_REAL;
      yold = NA_REAL;
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          /* do the conversion now to check for non-finite */
          GConvert(&xx, &yy, USER, DEVICE, dd);
          if ((R_FINITE(xx) && R_FINITE(yy)) &&
            !(R_FINITE(xold) && R_FINITE(yold)))
            start = i;
          else if ((R_FINITE(xold) && R_FINITE(yold)) &&
                 !(R_FINITE(xx) && R_FINITE(yy))) {
            if (i-start > 1)
                GPolyline(i-start, x+start, y+start, USER, dd);
          }
          else if ((R_FINITE(xold) && R_FINITE(yold)) && (i == n-1))
            GPolyline(n-start, x+start, y+start, USER, dd);
          xold = xx;
          yold = yy;
      }
      break;

    case 'b':
    case 'c': /* broken lines (with points in between if 'b') */
    {
      double d, f;
      d = GConvertYUnits(0.5, CHARS, INCHES, dd);
      gpptr(dd)->col = INTEGER(col)[0];
      xold = NA_REAL;
      yold = NA_REAL;
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          GConvert(&xx, &yy, USER, INCHES, dd);
          if (R_FINITE(xold) && R_FINITE(yold) &&
            R_FINITE(xx) && R_FINITE(yy)) {
            if ((f = d/hypot(xx-xold, yy-yold)) < 0.5) {
                GLine(xold + f * (xx - xold),
                    yold + f * (yy - yold),
                    xx + f * (xold - xx),
                    yy + f * (yold - yy),
                    INCHES, dd);
            }
          }
          xold = xx;
          yold = yy;
      }
    }
    break;

    case 's': /* step function      I */
    {
      double *xtemp, *ytemp;
      int n0 = 0;
      if(n <= 1000) {
          xtemp = (double *) alloca(2*n*sizeof(double));
          ytemp = (double *) alloca(2*n*sizeof(double));
          R_CheckStack();
      } else {
          vmax = vmaxget();
          xtemp = (double *) R_alloc(2*n, sizeof(double));
          ytemp = (double *) R_alloc(2*n, sizeof(double));
      }
      gpptr(dd)->col = INTEGER(col)[0];
      xold = NA_REAL;
      yold = NA_REAL;
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          GConvert(&xx, &yy, USER, DEVICE, dd);
          if ((R_FINITE(xx) && R_FINITE(yy)) &&
            (R_FINITE(xold) && R_FINITE(yold))) {
            if(n0 == 0) { xtemp[n0] = xold; ytemp[n0++] = yold; }
            xtemp[n0] = xx; ytemp[n0++] = yold;/* <-only diff 's' <-> 'S' */
            xtemp[n0] = xx;   ytemp[n0++] = yy;
          } else if( (R_FINITE(xold) && R_FINITE(yold)) &&
                   !(R_FINITE(xx)  && R_FINITE(yy))     && n0 > 0) {
            GPolyline(n0, xtemp, ytemp, DEVICE, dd);
            n0 = 0;
          }
          xold = xx;
          yold = yy;
      }
      if(n0 > 0) GPolyline(n0, xtemp, ytemp, DEVICE, dd);
      if(n > 1000) vmaxset(vmax);
    }
    break;

    case 'S': /* step function      II */
    {
      double *xtemp, *ytemp;
      int n0 = 0;
      if(n < 1000) {
          xtemp = (double *) alloca(2*n*sizeof(double));
          ytemp = (double *) alloca(2*n*sizeof(double));
          R_CheckStack();
      } else {
          vmax = vmaxget();
          xtemp = (double *) R_alloc(2*n, sizeof(double));
          ytemp = (double *) R_alloc(2*n, sizeof(double));
      }
      gpptr(dd)->col = INTEGER(col)[0];
      xold = NA_REAL;
      yold = NA_REAL;
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          GConvert(&xx, &yy, USER, DEVICE, dd);
          if ((R_FINITE(xx) && R_FINITE(yy)) &&
            (R_FINITE(xold) && R_FINITE(yold))) {
            if(n0 == 0) {xtemp[n0] = xold; ytemp[n0++] = yold;}
            xtemp[n0] = xold; ytemp[n0++] = yy;
            xtemp[n0] = xx;   ytemp[n0++] = yy;
          } else if( (R_FINITE(xold) && R_FINITE(yold)) &&
                   !(R_FINITE(xx)  && R_FINITE(yy))     && n0 > 0) {
            GPolyline(n0, xtemp, ytemp, DEVICE, dd);
            n0 = 0;
          }
          xold = xx;
          yold = yy;
      }
      if(n0 > 0) GPolyline(n0, xtemp, ytemp, DEVICE, dd);
      if(n > 1000) vmaxset(vmax);
    }
    break;

    case 'h': /* h[istogram] (bar plot) */
      if (gpptr(dd)->ylog)
          yold = gpptr(dd)->usr[2];/* DBL_MIN fails.. why ???? */
      else
          yold = 0.0;
      yold = GConvertY(yold, USER, DEVICE, dd);
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          GConvert(&xx, &yy, USER, DEVICE, dd);
          if (R_FINITE(xx) && R_FINITE(yy)
            && !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol])) {
            gpptr(dd)->col = thiscol;
            GLine(xx, yold, xx, yy, DEVICE, dd);
          }
      }
      break;

    case 'p':
    case 'n': /* nothing here */
      break;

    default:/* OTHERWISE */
      error(_("invalid plot type '%c'"), type);

    } /* End {switch(type)} - for lines */

    /* Points : */
    if (type == 'p' || type == 'b' || type == 'o') {
      for (i = 0; i < n; i++) {
          xx = x[i];
          yy = y[i];
          GConvert(&xx, &yy, USER, DEVICE, dd);
          if (R_FINITE(xx) && R_FINITE(yy)) {
            if (R_FINITE( (thiscex = REAL(cex)[i % ncex]) ) &&
                (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER) {
                thiscol = INTEGER(col)[i % ncol];
                thisbg = INTEGER(bg)[i % nbg];
                if (!(R_TRANSPARENT(thiscol) &&
                    R_TRANSPARENT(thisbg))) {
                  gpptr(dd)->cex = thiscex * gpptr(dd)->cexbase;
                  gpptr(dd)->col = thiscol;
                  if(nlwd > 1 &&
                     R_FINITE((thislwd = REAL(lwd)[i % nlwd])))
                      gpptr(dd)->lwd = thislwd;
                  gpptr(dd)->bg = thisbg;
                  GSymbol(xx, yy, DEVICE, thispch, dd);
                }
            }
          }
      }
    }
    GMode(0, dd);
    GRestorePars(dd);
    UNPROTECT(6);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}/* do_plot_xy */

/* Checks for ... , x0, y0, x1, y1 ... */

static void xypoints(SEXP call, SEXP args, int *n)
{
    int k=0;/* -Wall */

    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
      error(_("invalid first argument"));
    SETCAR(args, coerceVector(CAR(args), REALSXP));
    *n = k;
    args = CDR(args);

    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
      error(_("invalid second argument"));
    SETCAR(args, coerceVector(CAR(args), REALSXP));
    if (k > *n) *n = k;
    args = CDR(args);

    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
      error(_("invalid third argument"));
    SETCAR(args, coerceVector(CAR(args), REALSXP));
    if (k > *n) *n = k;
    args = CDR(args);

    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
      error(_("invalid fourth argument"));
    SETCAR(args, coerceVector(CAR(args), REALSXP));
    if (k > *n) *n = k;
    args = CDR(args);
}


SEXP attribute_hidden do_segments(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* segments(x0, y0, x1, y1, col, lty, lwd, ...) */
    SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
    double *x0, *x1, *y0, *y1;
    double xx[2], yy[2];
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    if (length(args) < 4) error(_("too few arguments"));
    GCheckState(dd);

    xypoints(call, args, &n);

    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
    sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
    sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
    sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);

    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
    ncol = LENGTH(col); args = CDR(args);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
    nlty = length(lty); args = CDR(args);

    PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
    nlwd = length(lwd); args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    x0 = REAL(sx0);
    y0 = REAL(sy0);
    x1 = REAL(sx1);
    y1 = REAL(sy1);

    GMode(1, dd);
    for (i = 0; i < n; i++) {
      xx[0] = x0[i%nx0];
      yy[0] = y0[i%ny0];
      xx[1] = x1[i%nx1];
      yy[1] = y1[i%ny1];
      GConvert(xx, yy, USER, DEVICE, dd);
      GConvert(xx+1, yy+1, USER, DEVICE, dd);
      if (R_FINITE(xx[0]) && R_FINITE(yy[0]) &&
          R_FINITE(xx[1]) && R_FINITE(yy[1]))
      {
          int thiscol = INTEGER(col)[i % ncol];
          if(!R_TRANSPARENT(thiscol)) {
            gpptr(dd)->col = thiscol;
            gpptr(dd)->lty = INTEGER(lty)[i % nlty];
            gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
            GLine(xx[0], yy[0], xx[1], yy[1], DEVICE, dd);
          }
      }
    }
    GMode(0, dd);
    GRestorePars(dd);

    UNPROTECT(3);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}


SEXP attribute_hidden do_rect(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* rect(xl, yb, xr, yt, col, border, lty, ...) */
    SEXP sxl, sxr, syb, syt, col, lty, lwd, border;
    double *xl, *xr, *yb, *yt, x0, y0, x1, y1;
    int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    if (length(args) < 4) error(_("too few arguments"));
    GCheckState(dd);

    xypoints(call, args, &n);
    sxl = CAR(args); nxl = length(sxl); args = CDR(args);/* x_left */
    syb = CAR(args); nyb = length(syb); args = CDR(args);/* y_bottom */
    sxr = CAR(args); nxr = length(sxr); args = CDR(args);/* x_right */
    syt = CAR(args); nyt = length(syt); args = CDR(args);/* y_top */

    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
    ncol = LENGTH(col);
    args = CDR(args);

    PROTECT(border =  FixupCol(CAR(args), gpptr(dd)->fg));
    nborder = LENGTH(border);
    args = CDR(args);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
    nlty = length(lty);
    args = CDR(args);

    PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
    nlwd = length(lwd);
    args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    xl = REAL(sxl);
    xr = REAL(sxr);
    yb = REAL(syb);
    yt = REAL(syt);

    GMode(1, dd);
    for (i = 0; i < n; i++) {
      if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)
          gpptr(dd)->lty = INTEGER(lty)[i % nlty];
      else
          gpptr(dd)->lty = dpptr(dd)->lty;
      if (nlwd && REAL(lwd)[i % nlwd] != NA_REAL)
          gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
      else
          gpptr(dd)->lwd = dpptr(dd)->lwd;
      x0 = xl[i%nxl];
      y0 = yb[i%nyb];
      x1 = xr[i%nxr];
      y1 = yt[i%nyt];
      GConvert(&x0, &y0, USER, DEVICE, dd);
      GConvert(&x1, &y1, USER, DEVICE, dd);
      if (R_FINITE(x0) && R_FINITE(y0) && R_FINITE(x1) && R_FINITE(y1))
          GRect(x0, y0, x1, y1, DEVICE, INTEGER(col)[i % ncol],
              INTEGER(border)[i % nborder], dd);
    }
    GMode(0, dd);

    GRestorePars(dd);
    UNPROTECT(4);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}


SEXP attribute_hidden do_arrows(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, ...) */
    SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
    double *x0, *x1, *y0, *y1;
    double xx0, yy0, xx1, yy1;
    double hlength, angle;
    int code;
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
    rcolor thiscol;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    if (length(args) < 4) error(_("too few arguments"));
    GCheckState(dd);

    xypoints(call, args, &n);

    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
    sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
    sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
    sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);

    hlength = asReal(CAR(args));
    if (!R_FINITE(hlength) || hlength < 0)
      error(_("invalid arrow head length"));
    args = CDR(args);

    angle = asReal(CAR(args));
    if (!R_FINITE(angle))
      error(_("invalid arrow head angle"));
    args = CDR(args);

    code = asInteger(CAR(args));
    if (code == NA_INTEGER || code < 0 || code > 3)
      error(_("invalid arrow head specification"));
    args = CDR(args);

    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
    ncol = LENGTH(col);
    args = CDR(args);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
    nlty = length(lty);
    args = CDR(args);

    PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
    nlwd = length(lwd);
    args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    x0 = REAL(sx0);
    y0 = REAL(sy0);
    x1 = REAL(sx1);
    y1 = REAL(sy1);

    GMode(1, dd);
    for (i = 0; i < n; i++) {
      xx0 = x0[i%nx0];
      yy0 = y0[i%ny0];
      xx1 = x1[i%nx1];
      yy1 = y1[i%ny1];
      GConvert(&xx0, &yy0, USER, DEVICE, dd);
      GConvert(&xx1, &yy1, USER, DEVICE, dd);
      if (R_FINITE(xx0) && R_FINITE(yy0) && R_FINITE(xx1) && R_FINITE(yy1)
          && !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol])) {
          gpptr(dd)->col = thiscol;
          gpptr(dd)->lty = INTEGER(lty)[i % nlty];
          gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
          GArrow(xx0, yy0, xx1, yy1, DEVICE,
               hlength, angle, code, dd);
      }
    }
    GMode(0, dd);
    GRestorePars(dd);

    UNPROTECT(3);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}


static void drawPolygon(int n, double *x, double *y,
                  int lty, int fill, int border, pGEDevDesc dd)
{
    if (lty == NA_INTEGER)
      gpptr(dd)->lty = dpptr(dd)->lty;
    else
      gpptr(dd)->lty = lty;
    GPolygon(n, x, y, USER, fill, border, dd);
}

SEXP attribute_hidden do_polygon(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* polygon(x, y, col, border, lty, ...) */
    SEXP sx, sy, col, border, lty;
    int nx;
    int ncol, nborder, nlty, i, start=0;
    int num = 0;
    double *x, *y, xx, yy, xold, yold;

    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);

    if (length(args) < 2) error(_("too few arguments"));
    /* (x,y) is checked in R via xy.coords() ; no need here : */
    sx = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
    sy = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
    nx = LENGTH(sx);

    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));  args = CDR(args);
    ncol = LENGTH(col);

    PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg)); args = CDR(args);
    nborder = LENGTH(border);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty)); args = CDR(args);
    nlty = length(lty);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    GMode(1, dd);

    x = REAL(sx);
    y = REAL(sy);
    xold = NA_REAL;
    yold = NA_REAL;
    for (i = 0; i < nx; i++) {
      xx = x[i];
      yy = y[i];
      GConvert(&xx, &yy, USER, DEVICE, dd);
      if ((R_FINITE(xx) && R_FINITE(yy)) &&
          !(R_FINITE(xold) && R_FINITE(yold)))
          start = i; /* first point of current segment */
      else if ((R_FINITE(xold) && R_FINITE(yold)) &&
             !(R_FINITE(xx) && R_FINITE(yy))) {
          if (i-start > 1) {
            drawPolygon(i-start, x+start, y+start,
                      INTEGER(lty)[num%nlty],
                      INTEGER(col)[num%ncol],
                      INTEGER(border)[num%nborder], dd);
            num++;
          }
      }
      else if ((R_FINITE(xold) && R_FINITE(yold)) && (i == nx-1)) { /* last */
          drawPolygon(nx-start, x+start, y+start,
                  INTEGER(lty)[num%nlty],
                  INTEGER(col)[num%ncol],
                  INTEGER(border)[num%nborder], dd);
          num++;
      }
      xold = xx;
      yold = yy;
    }

    GMode(0, dd);

    GRestorePars(dd);
    UNPROTECT(3);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}

SEXP attribute_hidden do_text(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* text(xy, labels, adj, pos, offset,
 *    vfont, cex, col, font, ...)
 */
    SEXP sx, sy, sxy, txt, adj, pos, cex, col, rawcol, font, vfont;
    int i, n, npos, ncex, ncol, nfont, ntxt;
    double adjx = 0, adjy = 0, offset = 0.5;
    double *x, *y;
    double xx, yy;
    Rboolean vectorFonts = FALSE;
    SEXP string, originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);

    if (length(args) < 3) error(_("too few arguments"));

    PLOT_XY_DEALING("text");

    /* labels */
    txt = CAR(args);
    if (isSymbol(txt) || isLanguage(txt))
      txt = coerceVector(txt, EXPRSXP);
    else if (!isExpression(txt))
      txt = coerceVector(txt, STRSXP);
    PROTECT(txt);
    if (length(txt) <= 0)
      error(_("zero length 'labels'"));
    args = CDR(args);

    PROTECT(adj = CAR(args));
    if (isNull(adj) || (isNumeric(adj) && length(adj) == 0)) {
      adjx = gpptr(dd)->adj;
      adjy = NA_REAL;
    }
    else if (isReal(adj)) {
      if (LENGTH(adj) == 1) {
          adjx = REAL(adj)[0];
          adjy = NA_REAL;
      }
      else {
          adjx = REAL(adj)[0];
          adjy = REAL(adj)[1];
      }
    }
    else if (isInteger(adj)) {
      if (LENGTH(adj) == 1) {
          adjx = INTEGER(adj)[0];
          adjy = NA_REAL;
      }
      else {
          adjx = INTEGER(adj)[0];
          adjy = INTEGER(adj)[1];
      }
    }
    else error(_("invalid '%s' value"), "adj");
    args = CDR(args);

    PROTECT(pos = coerceVector(CAR(args), INTSXP));
    npos = length(pos);
    for (i = 0; i < npos; i++)
      if (INTEGER(pos)[i] < 1 || INTEGER(pos)[i] > 4)
          error(_("invalid '%s' value"), "pos");
    args = CDR(args);

    offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);
    args = CDR(args);

    PROTECT(vfont = FixupVFont(CAR(args)));
    args = CDR(args);

    PROTECT(cex = FixupCex(CAR(args), 1.0));
    ncex = LENGTH(cex);
    args = CDR(args);

    rawcol = CAR(args);
    PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
    ncol = LENGTH(col);
    args = CDR(args);

    PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
    nfont = LENGTH(font);
    args = CDR(args);

    x = REAL(sx);
    y = REAL(sy);
    /* n = LENGTH(sx) = LENGTH(sy) */
    ntxt = LENGTH(txt);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    /* Done here so 'vfont' trumps inline 'family' */
    if (!isNull(vfont) && !isExpression(txt)) {
      strncpy(gpptr(dd)->family, "Her ", 201);
      gpptr(dd)->family[3] = INTEGER(vfont)[0];
      vectorFonts = TRUE;
    }

    GMode(1, dd);
    if (n == 0 && ntxt > 0)
      error(_("no coordinates were supplied"));
    for (i = 0; i < imax2(n,ntxt); i++) {
      xx = x[i % n];
      yy = y[i % n];
      GConvert(&xx, &yy, USER, INCHES, dd);
      if (R_FINITE(xx) && R_FINITE(yy)) {
          if (ncol && !isNAcol(rawcol, i, ncol))
            gpptr(dd)->col = INTEGER(col)[i % ncol];
          else
            gpptr(dd)->col = dpptr(dd)->col;
          if (ncex && R_FINITE(REAL(cex)[i%ncex]))
            gpptr(dd)->cex = gpptr(dd)->cexbase * REAL(cex)[i % ncex];
          else
            gpptr(dd)->cex = gpptr(dd)->cexbase;

          if (vectorFonts) gpptr(dd)->font = INTEGER(vfont)[1];
          else if (nfont && INTEGER(font)[i % nfont] != NA_INTEGER)
            gpptr(dd)->font = INTEGER(font)[i % nfont];
          else
            gpptr(dd)->font = dpptr(dd)->font;

          if (npos > 0) {
            switch(INTEGER(pos)[i % npos]) {
            case 1:
                yy = yy - offset;
                adjx = 0.5;
                adjy = 1 - (0.5 - dd->dev->yCharOffset);
                break;
            case 2:
                xx = xx - offset;
                adjx = 1;
                adjy = dd->dev->yCharOffset;
                break;
            case 3:
                yy = yy + offset;
                adjx = 0.5;
                adjy = 0;
                break;
            case 4:
                xx = xx + offset;
                adjx = 0;
                adjy = dd->dev->yCharOffset;
                break;
            }
          }
          if (isExpression(txt)) {
            GMathText(xx, yy, INCHES, VECTOR_ELT(txt, i % ntxt),
                    adjx, adjy, gpptr(dd)->srt, dd);
          } else {
            string = STRING_ELT(txt, i % ntxt);
            if(string != NA_STRING)
                GText(xx, yy, INCHES, CHAR(string), getCharCE(string),
                    adjx, adjy, gpptr(dd)->srt, dd);
          }
      }
    }
    GMode(0, dd);

    GRestorePars(dd);
    UNPROTECT(7);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}

static double ComputeAdjValue(double adj, int side, int las)
{
    if (!R_FINITE(adj)) {
      switch(las) {
      case 0:/* parallel to axis */
          adj = 0.5; break;
      case 1:/* horizontal */
          switch(side) {
          case 1:
          case 3: adj = 0.5; break;
          case 2: adj = 1.0; break;
          case 4: adj = 0.0; break;
          }
          break;
      case 2:/* perpendicular to axis */
          switch(side) {
          case 1:
          case 2: adj = 1.0; break;
          case 3:
          case 4: adj = 0.0; break;
          }
          break;
      case 3:/* vertical */
          switch(side) {
          case 1: adj = 1.0; break;
          case 3: adj = 0.0; break;
          case 2:
          case 4: adj = 0.5; break;
          }
          break;
      }
    }
    return adj;
}

static double ComputeAtValueFromAdj(double adj, int side, int outer,
                            pGEDevDesc dd)
{
    double at = 0;            /* -Wall */
    switch(side % 2) {
    case 0:
      at  = outer ? adj : yNPCtoUsr(adj, dd);
      break;
    case 1:
      at = outer ? adj : xNPCtoUsr(adj, dd);
      break;
    }
    return at;
}

static double ComputeAtValue(double at, double adj,
                       int side, int las, int outer,
                       pGEDevDesc dd)
{
    if (!R_FINITE(at)) {
      /* If the text is parallel to the axis, use "adj" for "at"
       * Otherwise, centre the text
       */
      switch(las) {
      case 0:/* parallel to axis */
          at = ComputeAtValueFromAdj(adj, side, outer, dd);
          break;
      case 1:/* horizontal */
          switch(side) {
          case 1:
          case 3:
            at = ComputeAtValueFromAdj(adj, side, outer, dd);
            break;
          case 2:
          case 4:
            at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
            break;
          }
          break;
      case 2:/* perpendicular to axis */
          switch(side) {
          case 1:
          case 3:
            at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
            break;
          case 2:
          case 4:
            at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
            break;
          }
          break;
      case 3:/* vertical */
          switch(side) {
          case 1:
          case 3:
            at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
            break;
          case 2:
          case 4:
            at = ComputeAtValueFromAdj(adj, side, outer, dd);
            break;
          }
          break;
      }
    }
    return at;
}

/* mtext(text,
       side = 3,
       line = 0,
       outer = TRUE,
       at = NA,
       adj = NA,
       padj = NA,
       cex = NA,
       col = NA,
       font = NA,
       ...) */

SEXP attribute_hidden do_mtext(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP text, side, line, outer, at, adj, padj, cex, col, font, string;
    SEXP rawcol;
    int ntext, nside, nline, nouter, nat, nadj, npadj, ncex, ncol, nfont;
    Rboolean dirtyplot = FALSE, gpnewsave = FALSE, dpnewsave = FALSE;
    int i, n, fontsave, colsave;
    double cexsave;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);

    if (length(args) < 9)
      error(_("too few arguments"));

    /* Arg1 : text= */
    text = CAR(args);
    if (isSymbol(text) || isLanguage(text))
      text = coerceVector(text, EXPRSXP);
    else if (!isExpression(text))
      text = coerceVector(text, STRSXP);
    PROTECT(text);
    n = ntext = length(text);
    if (ntext <= 0)
      error(_("zero length 'text' specified"));
    args = CDR(args);

    /* Arg2 : side= */
    PROTECT(side = coerceVector(CAR(args), INTSXP));
    nside = length(side);
    if (nside <= 0) error(_("zero length 'side' specified"));
    if (n < nside) n = nside;
    args = CDR(args);

    /* Arg3 : line= */
    PROTECT(line = coerceVector(CAR(args), REALSXP));
    nline = length(line);
    if (nline <= 0) error(_("zero length 'line' specified"));
    if (n < nline) n = nline;
    args = CDR(args);

    /* Arg4 : outer= */
    /* outer == NA => outer <- 0 */
    PROTECT(outer = coerceVector(CAR(args), INTSXP));
    nouter = length(outer);
    if (nouter <= 0) error(_("zero length 'outer' specified"));
    if (n < nouter) n = nouter;
    args = CDR(args);

    /* Arg5 : at= */
    PROTECT(at = coerceVector(CAR(args), REALSXP));
    nat = length(at);
    if (nat <= 0) error(_("zero length 'at' specified"));
    if (n < nat) n = nat;
    args = CDR(args);

    /* Arg6 : adj= */
    PROTECT(adj = coerceVector(CAR(args), REALSXP));
    nadj = length(adj);
    if (nadj <= 0) error(_("zero length 'adj' specified"));
    if (n < nadj) n = nadj;
    args = CDR(args);

    /* Arg7 : padj= */
    PROTECT(padj = coerceVector(CAR(args), REALSXP));
    npadj = length(padj);
    if (npadj <= 0) error(_("zero length 'padj' specified"));
    if (n < npadj) n = npadj;
    args = CDR(args);

    /* Arg8 : cex */
    PROTECT(cex = FixupCex(CAR(args), 1.0));
    ncex = length(cex);
    if (ncex <= 0) error(_("zero length 'cex' specified"));
    if (n < ncex) n = ncex;
    args = CDR(args);

    /* Arg9 : col */
    rawcol = CAR(args);
    PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
    ncol = length(col);
    if (ncol <= 0) error(_("zero length 'col' specified"));
    if (n < ncol) n = ncol;
    args = CDR(args);

    /* Arg10 : font */
    PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
    nfont = length(font);
    if (nfont <= 0) error(_("zero length 'font' specified"));
    if (n < nfont) n = nfont;
    args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    /* If we only scribble in the outer margins, */
    /* we don't want to mark the plot as dirty. */

    dirtyplot = FALSE;
    gpnewsave = gpptr(dd)->new;
    dpnewsave = dpptr(dd)->new;
    cexsave = gpptr(dd)->cex;
    fontsave = gpptr(dd)->font;
    colsave = gpptr(dd)->col;

    /* override par("xpd") and force clipping to figure region */
    /* NOTE: don't override to _reduce_ clipping region */
    if (gpptr(dd)->xpd < 1)
      gpptr(dd)->xpd = 1;

    if (outer) {
      gpnewsave = gpptr(dd)->new;
      dpnewsave = dpptr(dd)->new;
      /* override par("xpd") and force clipping to device region */
      gpptr(dd)->xpd = 2;
    }
    GMode(1, dd);

    for (i = 0; i < n; i++) {
      double atval = REAL(at)[i%nat];
      double adjval = REAL(adj)[i%nadj];
      double padjval = REAL(padj)[i%npadj];
      double cexval = REAL(cex)[i%ncex];
      double lineval = REAL(line)[i%nline];
      int outerval = INTEGER(outer)[i%nouter];
      int sideval = INTEGER(side)[i%nside];
      int fontval = INTEGER(font)[i%nfont];
      int colval = INTEGER(col)[i%ncol];

      if (outerval == NA_INTEGER) outerval = 0;
      /* Note : we ignore any shrinking produced */
      /* by mfrow / mfcol specs here.      I.e. don't */
      /* gpptr(dd)->cexbase. */
      if (R_FINITE(cexval)) gpptr(dd)->cex = cexval;
      else cexval = cexsave;
      gpptr(dd)->font = (fontval == NA_INTEGER) ? fontsave : fontval;
      if (isNAcol(rawcol, i, ncol))
          gpptr(dd)->col = colsave;
      else
          gpptr(dd)->col = colval;
      gpptr(dd)->adj = ComputeAdjValue(adjval, sideval, gpptr(dd)->las);
      padjval = ComputePAdjValue(padjval, sideval, gpptr(dd)->las);
      atval = ComputeAtValue(atval, gpptr(dd)->adj, sideval, gpptr(dd)->las,
                         outerval, dd);

      if (isExpression(text))
          GMMathText(VECTOR_ELT(text, i%ntext),
                   sideval, lineval, outerval, atval, gpptr(dd)->las,
                   padjval, dd);
      else {
          string = STRING_ELT(text, i%ntext);
          if(string != NA_STRING)
            GMtext(CHAR(string), getCharCE(string), sideval, lineval,
                   outerval, atval, gpptr(dd)->las, padjval, dd);
      }

      if (outerval == 0) dirtyplot = TRUE;
    }
    GMode(0, dd);

    GRestorePars(dd);
    if (!dirtyplot) {
      gpptr(dd)->new = gpnewsave;
      dpptr(dd)->new = dpnewsave;
    }
    UNPROTECT(10);

    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}/* do_mtext */


SEXP attribute_hidden do_title(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* Annotation for plots :

   title(main, sub, xlab, ylab,
       line, outer,
       ...) */

    SEXP Main, xlab, ylab, sub, string;
    double adj, adjy, cex, offset, line, hpos, vpos, where;
    int i, n, font, outer;
    rcolor col;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);

    if (length(args) < 6) error(_("too few arguments"));

    Main = sub = xlab = ylab = R_NilValue;

    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
      Main = CAR(args);
    args = CDR(args);

    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
      sub = CAR(args);
    args = CDR(args);

    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
      xlab = CAR(args);
    args = CDR(args);

    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
      ylab = CAR(args);
    args = CDR(args);

    line = asReal(CAR(args));
    args = CDR(args);

    outer = asLogical(CAR(args));
    if (outer == NA_LOGICAL) outer = 0;
    args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    /* override par("xpd") and force clipping to figure region */
    /* NOTE: don't override to _reduce_ clipping region */
    if (gpptr(dd)->xpd < 1)
      gpptr(dd)->xpd = 1;
    if (outer)
      gpptr(dd)->xpd = 2;
    adj = gpptr(dd)->adj;

    GMode(1, dd);
    if (Main != R_NilValue) {
      cex = gpptr(dd)->cexmain;
      col = gpptr(dd)->colmain;
      font = gpptr(dd)->fontmain;
      /* GetTextArg may coerce, so protect the result */
      GetTextArg(call, Main, &Main, &col, &cex, &font);
      PROTECT(Main);
      gpptr(dd)->col = col;
      gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
      gpptr(dd)->font = font;
      if (outer) {
          if (R_FINITE(line)) {
            vpos = line;
            adjy = 0;
          }
          else {
            vpos = 0.5 * gpptr(dd)->oma[2];
            adjy = 0.5;
          }
          hpos = adj;
          where = OMA3;
      }
      else {
          if (R_FINITE(line)) {
            vpos = line;
            adjy = 0;
          }
          else {
            vpos = 0.5 * gpptr(dd)->mar[2];
            adjy = 0.5;
          }
          hpos = GConvertX(adj, NPC, USER, dd);
          where = MAR3;
      }
      if (isExpression(Main)) {
          GMathText(hpos, vpos, where, VECTOR_ELT(Main, 0),
                  adj, 0.5, 0.0, dd);
      }
      else {
        n = length(Main);
        offset = 0.5 * (n - 1) + vpos;
        for (i = 0; i < n; i++) {
            string = STRING_ELT(Main, i);
            if(string != NA_STRING)
                GText(hpos, offset - i, where, CHAR(string), getCharCE(string),
                    adj, adjy, 0.0, dd);
        }
      }
      UNPROTECT(1);
    }
    if (sub != R_NilValue) {
      cex = gpptr(dd)->cexsub;
      col = gpptr(dd)->colsub;
      font = gpptr(dd)->fontsub;
      /* GetTextArg may coerce, so protect the result */
      GetTextArg(call, sub, &sub, &col, &cex, &font);
      PROTECT(sub);
      gpptr(dd)->col = col;
      gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
      gpptr(dd)->font = font;
      if (R_FINITE(line))
          vpos = line;
      else
          vpos = gpptr(dd)->mgp[0] + 1;
      if (outer) {
          hpos = adj;
          where = 1;
      }
      else {
          hpos = GConvertX(adj, NPC, USER, dd);
          where = 0;
      }
      if (isExpression(sub))
          GMMathText(VECTOR_ELT(sub, 0), 1, vpos, where,
                   hpos, 0, 0.0, dd);
      else {
          n = length(sub);
          for (i = 0; i < n; i++) {
            string = STRING_ELT(sub, i);
            if(string != NA_STRING)
                GMtext(CHAR(string), getCharCE(string), 1, vpos, where,
                     hpos, 0, 0.0, dd);
          }
      }
      UNPROTECT(1);
    }
    if (xlab != R_NilValue) {
      cex = gpptr(dd)->cexlab;
      col = gpptr(dd)->collab;
      font = gpptr(dd)->fontlab;
      /* GetTextArg may coerce, so protect the result */
      GetTextArg(call, xlab, &xlab, &col, &cex, &font);
      PROTECT(xlab);
      gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
      gpptr(dd)->col = col;
      gpptr(dd)->font = font;
      if (R_FINITE(line))
          vpos = line;
      else
          vpos = gpptr(dd)->mgp[0];
      if (outer) {
          hpos = adj;
          where = 1;
      }
      else {
          hpos = GConvertX(adj, NPC, USER, dd);
          where = 0;
      }
      if (isExpression(xlab))
          GMMathText(VECTOR_ELT(xlab, 0), 1, vpos, where,
                   hpos, 0, 0.0, dd);
      else {
          n = length(xlab);
          for (i = 0; i < n; i++) {
            string = STRING_ELT(xlab, i);
            if(string != NA_STRING)
                GMtext(CHAR(string), getCharCE(string), 1, vpos + i,
                     where, hpos, 0, 0.0, dd);
          }
      }
      UNPROTECT(1);
    }
    if (ylab != R_NilValue) {
      cex = gpptr(dd)->cexlab;
      col = gpptr(dd)->collab;
      font = gpptr(dd)->fontlab;
      /* GetTextArg may coerce, so protect the result */
      GetTextArg(call, ylab, &ylab, &col, &cex, &font);
      PROTECT(ylab);
      gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
      gpptr(dd)->col = col;
      gpptr(dd)->font = font;
      if (R_FINITE(line))
          vpos = line;
      else
          vpos = gpptr(dd)->mgp[0];
      if (outer) {
          hpos = adj;
          where = 1;
      }
      else {
          hpos = GConvertY(adj, NPC, USER, dd);
          where = 0;
      }
      if (isExpression(ylab))
          GMMathText(VECTOR_ELT(ylab, 0), 2, vpos, where,
                   hpos, 0, 0.0, dd);
      else {
          n = length(ylab);
          for (i = 0; i < n; i++) {
            string = STRING_ELT(ylab, i);
            if(string != NA_STRING)
                GMtext(CHAR(string), getCharCE(string), 2, vpos - i,
                     where, hpos, 0, 0.0, dd);
          }
      }
      UNPROTECT(1);
    }
    GMode(0, dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}/* do_title */


/*  abline(a, b, h, v, col, lty, lwd, ...)
    draw lines in intercept/slope form.    */

SEXP attribute_hidden do_abline(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP a, b, h, v, untf, col, lty, lwd;
    int i, ncol, nlines, nlty, nlwd, lstart, lstop;
    double aa, bb, x[2], y[2]={0.,0.} /* -Wall */;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);

    if (length(args) < 5) error(_("too few arguments"));

    if ((a = CAR(args)) != R_NilValue)
      SETCAR(args, a = coerceVector(a, REALSXP));
    args = CDR(args);

    if ((b = CAR(args)) != R_NilValue)
      SETCAR(args, b = coerceVector(b, REALSXP));
    args = CDR(args);

    if ((h = CAR(args)) != R_NilValue)
      SETCAR(args, h = coerceVector(h, REALSXP));
    args = CDR(args);

    if ((v = CAR(args)) != R_NilValue)
      SETCAR(args, v = coerceVector(v, REALSXP));
    args = CDR(args);

    if ((untf = CAR(args)) != R_NilValue)
      SETCAR(args, untf = coerceVector(untf, LGLSXP));
    args = CDR(args);


    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));  args = CDR(args);
    ncol = LENGTH(col);

    PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty)); args = CDR(args);
    nlty = length(lty);

    PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd)); args = CDR(args);
    nlwd = length(lwd);

    GSavePars(dd);

    ProcessInlinePars(args, dd, call);

    nlines = 0;

    if (a != R_NilValue) {
      if (b == R_NilValue) {
          if (LENGTH(a) != 2)
            error(_("invalid a=, b= specification"));
          aa = REAL(a)[0];
          bb = REAL(a)[1];
      }
      else {
          aa = asReal(a);
          bb = asReal(b);
      }
      if (!R_FINITE(aa) || !R_FINITE(bb))
          error(_("'a' and 'b' must be finite"));
      gpptr(dd)->col = INTEGER(col)[0];
      gpptr(dd)->lwd = REAL(lwd)[0];
      if (nlty && INTEGER(lty)[0] != NA_INTEGER)
          gpptr(dd)->lty = INTEGER(lty)[0];
      else
          gpptr(dd)->lty = dpptr(dd)->lty;
      GMode(1, dd);
      /* FIXME?
       * Seems like the logic here is just draw from xmin to xmax
       * and you're guaranteed to draw at least from ymin to ymax
       * This MAY cause a problem at some stage when the line being
       * drawn is VERY steep -- and the problem is worse now that
       * abline will potentially draw to the extents of the device
       * (when xpd=NA).  NOTE that R's internal clipping protects the
       * device drivers from stupidly large numbers, BUT there is
       * still a risk that we could produce a number which is too
       * big for the computer's brain.
       * Paul.
       *
       * The problem is worse -- you could get NaN, which at least the
       * X11 device coerces to -2^31 <TSL>
       */
      getxlimits(x, dd);
      if (R_FINITE(gpptr(dd)->lwd)) {
          if (LOGICAL(untf)[0] == 1 && (gpptr(dd)->xlog || gpptr(dd)->ylog)) {
            double xx[101], yy[101];
            double xstep = (x[1] - x[0])/100;
            for (i = 0; i < 100; i++) {
                xx[i] = x[0] + i*xstep;
                yy[i] = aa + xx[i] * bb;
            }
            xx[100] = x[1];
            yy[100] = aa + x[1] * bb;

            /* now get rid of -ve values */
            lstart=0;lstop=100;
            if (gpptr(dd)->xlog){
                  for(;xx[lstart]<=0 && lstart<101;lstart++);
                  for(;xx[lstop]<=0 && lstop>0;lstop--);
            }
            if (gpptr(dd)->ylog){
                  for(;yy[lstart]<=0 && lstart<101;lstart++);
                  for(;yy[lstop]<=0 && lstop>0;lstop--);
            }


            GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);
          }
          else {
            double x0, x1;

            x0 = ( gpptr(dd)->xlog ) ?    log10(x[0]) : x[0];
            x1 = ( gpptr(dd)->xlog ) ?    log10(x[1]) : x[1];

            y[0] = aa + x0 * bb;
            y[1] = aa + x1 * bb;

            if ( gpptr(dd)->ylog ){
                y[0] = pow(10.,y[0]);
                y[1] = pow(10.,y[1]);
            }

            GLine(x[0], y[0], x[1], y[1], USER, dd);
          }
      }
      GMode(0, dd);
      nlines++;
    }
    if (h != R_NilValue) {
      GMode(1, dd);
      for (i = 0; i < LENGTH(h); i++) {
          gpptr(dd)->col = INTEGER(col)[nlines % ncol];
          if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
            gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
          else
            gpptr(dd)->lty = dpptr(dd)->lty;
          gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
          aa = REAL(h)[i];
          if (R_FINITE(aa) && R_FINITE(gpptr(dd)->lwd)) {
            getxlimits(x, dd);
            y[0] = aa;
            y[1] = aa;
            GLine(x[0], y[0], x[1], y[1], USER, dd);
          }
          nlines++;
      }
      GMode(0, dd);
    }
    if (v != R_NilValue) {
      GMode(1, dd);
      for (i = 0; i < LENGTH(v); i++) {
          gpptr(dd)->col = INTEGER(col)[nlines % ncol];
          if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
            gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
          else
            gpptr(dd)->lty = dpptr(dd)->lty;
          gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
          aa = REAL(v)[i];
          if (R_FINITE(aa) && R_FINITE(gpptr(dd)->lwd)) {
            getylimits(y, dd);
            x[0] = aa;
            x[1] = aa;
            GLine(x[0], y[0], x[1], y[1], USER, dd);
          }
          nlines++;
      }
      GMode(0, dd);
    }
    UNPROTECT(3);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
} /* do_abline */


SEXP attribute_hidden do_box(SEXP call, SEXP op, SEXP args, SEXP env)
{
/*     box(which="plot", lty="solid", ...)
       --- which is coded, 1 = plot, 2 = figure, 3 = inner, 4 = outer.
*/
    int which, col;
    SEXP colsxp, fgsxp;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    GCheckState(dd);
    GSavePars(dd);
    which = asInteger(CAR(args)); args = CDR(args);
    if (which < 1 || which > 4)
      error(_("invalid '%s' argument"), "which");
    /*
     * If specified non-NA col then use that, else ...
     *
     * if specified non-NA fg then use that, else ...
     *
     * else use par("col")
     */
    col= gpptr(dd)->col;
    ProcessInlinePars(args, dd, call);
    colsxp = getInlinePar(args, "col");
    if (isNAcol(colsxp, 0, 1)) {
      fgsxp = getInlinePar(args, "fg");
      if (isNAcol(fgsxp, 0, 1))
          gpptr(dd)->col = col;
      else
          gpptr(dd)->col = gpptr(dd)->fg;
    }
    /* override par("xpd") and force clipping to device region */
    gpptr(dd)->xpd = 2;
    GMode(1, dd);
    GBox(which, dd);
    GMode(0, dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;
}

static void drawPointsLines(double xp, double yp, double xold, double yold,
                      char type, int first, pGEDevDesc dd)
{
    if (type == 'p' || type == 'o')
      GSymbol(xp, yp, DEVICE, gpptr(dd)->pch, dd);
    if ((type == 'l' || type == 'o') && !first)
      GLine(xold, yold, xp, yp, DEVICE, dd);
}

SEXP attribute_hidden do_locator(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, y, nobs, ans, saveans, stype = R_NilValue;
    int i, n, type='p';
    double xp, yp, xold=0, yold=0;
    pGEDevDesc dd = GEcurrentDevice();

    /* If replaying, just draw the points and lines that were recorded */
    if (call == R_NilValue) {
      x = CAR(args); args = CDR(args);
      y = CAR(args); args = CDR(args);
      nobs = CAR(args); args = CDR(args);
      n = INTEGER(nobs)[0];
      stype = CAR(args); args = CDR(args);
      type = CHAR(STRING_ELT(stype, 0))[0];
      if (type != 'n') {
          GMode(1, dd);
          for (i = 0; i < n; i++) {
            xp = REAL(x)[i];
            yp = REAL(y)[i];
            GConvert(&xp, &yp, USER, DEVICE, dd);
            drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
            xold = xp;
            yold = yp;
          }
          GMode(0, dd);
      }
      return R_NilValue;
    } else {
      GCheckState(dd);

      checkArity(op, args);
      n = asInteger(CAR(args));
      if (n <= 0 || n == NA_INTEGER)
          error(_("invalid number of points in locator()"));
      args = CDR(args);
      if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)
          stype = CAR(args);
      else
          error(_("invalid plot type"));
      type = CHAR(STRING_ELT(stype, 0))[0];
      PROTECT(x = allocVector(REALSXP, n));
      PROTECT(y = allocVector(REALSXP, n));
      PROTECT(nobs=allocVector(INTSXP,1));

      GMode(2, dd);
      for (i = 0; i < n; i++) {
          if (!GLocator(&(REAL(x)[i]), &(REAL(y)[i]), USER, dd)) break;
          if (type != 'n') {
            GMode(1, dd);
            xp = REAL(x)[i];
            yp = REAL(y)[i];
            GConvert(&xp, &yp, USER, DEVICE, dd);
            drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
            GMode(0, dd);
            GMode(2, dd);
            xold = xp; yold = yp;
          }
      }
      GMode(0, dd);
      INTEGER(nobs)[0] = i;
      for (; i < n; i++) {
          REAL(x)[i] = NA_REAL;
          REAL(y)[i] = NA_REAL;
      }
      PROTECT(ans = allocList(3));
      SETCAR(ans, x);
      SETCADR(ans, y);
      SETCADDR(ans, nobs);
      PROTECT(saveans = allocList(4));
      SETCAR(saveans, x);
      SETCADR(saveans, y);
      SETCADDR(saveans, nobs);
      SETCADDDR(saveans, CAR(args));
      /* Record the points and lines that were drawn in the display list */
      GErecordGraphicOperation(op, saveans, dd);
      UNPROTECT(5);
      return ans;
    }
}

static void drawLabel(double xi, double yi, int pos, double offset,
                  const char *l, cetype_t enc, pGEDevDesc dd)
{
    switch (pos) {
    case 4:
      xi = xi+offset;
      GText(xi, yi, INCHES, l, enc, 0.0,
            dd->dev->yCharOffset, 0.0, dd);
      break;
    case 2:
      xi = xi-offset;
      GText(xi, yi, INCHES, l, enc, 1.0,
            dd->dev->yCharOffset, 0.0, dd);
      break;
    case 3:
      yi = yi+offset;
      GText(xi, yi, INCHES, l, enc, 0.5,
            0.0, 0.0, dd);
      break;
    case 1:
      yi = yi-offset;
      GText(xi, yi, INCHES, l, enc, 0.5,
            1-(0.5-dd->dev->yCharOffset),
            0.0, dd);
      break;
    case 0:
      GText(xi, yi, INCHES, l, enc, 0.0, 0.0, 0.0, dd);
      break;
    }
}

/* This manages R_Visible */
SEXP attribute_hidden do_identify(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, x, y, l, ind, pos, Offset, draw, saveans;
    double xi, yi, xp, yp, d, dmin, offset, tol;
    int atpen, i, imin, k, n, nl, npts, plot, posi, warn;
    pGEDevDesc dd = GEcurrentDevice();

    /* If we are replaying the display list, then just redraw the
       labels beside the identified points */
    if (call == R_NilValue) {
      ind = CAR(args); args = CDR(args);
      pos = CAR(args); args = CDR(args);
      x = CAR(args); args = CDR(args);
      y = CAR(args); args = CDR(args);
      Offset = CAR(args); args = CDR(args);
      l = CAR(args); args = CDR(args);
      draw = CAR(args);
      n = LENGTH(x);
      nl = LENGTH(l);
      /*
       * Most of the appropriate settings have been set up in
       * R code by par(...)
       * Hence no GSavePars() or ProcessInlinePars() here
       * (also because this function is unusual in that it does
       *  different things when run by a user compared to when
       *  run from the display list)
       * BUT par(cex) only sets cexbase, so here we set cex from cexbase
       */
      gpptr(dd)->cex = gpptr(dd)->cexbase;
      offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
      for (i = 0; i < n; i++) {
          plot = LOGICAL(ind)[i];
          if (LOGICAL(draw)[0] && plot) {
            xi = REAL(x)[i];
            yi = REAL(y)[i];
            GConvert(&xi, &yi, USER, INCHES, dd);
            posi = INTEGER(pos)[i];
            drawLabel(xi, yi, posi, offset,
                    CHAR(STRING_ELT(l, i % nl)),
                    getCharCE(STRING_ELT(l, i % nl)), dd);
          }
      }
      return R_NilValue;
    }
    else {
      GCheckState(dd);

      checkArity(op, args);
      x = CAR(args); args = CDR(args);
      y = CAR(args); args = CDR(args);
      l = CAR(args); args = CDR(args);
      npts = asInteger(CAR(args)); args = CDR(args);
      plot = asLogical(CAR(args)); args = CDR(args);
      Offset = CAR(args); args = CDR(args);
      tol = asReal(CAR(args)); args = CDR(args);
      atpen = asLogical(CAR(args));
      if (npts <= 0 || npts == NA_INTEGER)
          error(_("invalid number of points in identify()"));
      if (!isReal(x) || !isReal(y) || !isString(l) || !isReal(Offset))
          error(_("incorrect argument type"));
      if (tol <= 0 || ISNAN(tol))
          error(_("invalid '%s' value"), "tolerance");
      if (plot == NA_LOGICAL)
          error(_("invalid '%s' value"), "plot");
      if (atpen == NA_LOGICAL)
          error(_("invalid '%s' value"), "atpen");
      nl = LENGTH(l);
      if (nl <= 0)
          error(_("zero length 'labels'"));
      n = LENGTH(x);
      if (n != LENGTH(y))
          error(_("different argument lengths"));
      if (nl > n)
          warning(_("more 'labels' than points"));
      if (n <= 0) {
          R_Visible = FALSE;
          return NULL;
      }

      /*
       * Most of the appropriate settings have been set up in
       * R code by par(...)
       * Hence no GSavePars() or ProcessInlinePars() here
       * (also because this function is unusual in that it does
       *  different things when run by a user compared to when
       *  run from the display list)
       * BUT par(cex) only sets cexbase, so here we set cex from cexbase
       */
      gpptr(dd)->cex = gpptr(dd)->cexbase;
      offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
      PROTECT(ind = allocVector(LGLSXP, n));
      PROTECT(pos = allocVector(INTSXP, n));
      for (i = 0; i < n; i++) LOGICAL(ind)[i] = 0;

      k = 0;
      GMode(2, dd);
      PROTECT(x = duplicate(x));
      PROTECT(y = duplicate(y));
      while (k < npts) {
          if (!GLocator(&xp, &yp, INCHES, dd)) break;
          /*
           * Repeat cex setting from cexbase within loop
           * so that if window is redrawn
           * (e.g., conver/uncover window)
           * during identifying (i.e., between clicks)
           * we reset cex properly.
           */
          gpptr(dd)->cex = gpptr(dd)->cexbase;
          dmin = DBL_MAX;
          imin = -1;
          for (i = 0; i < n; i++) {
            xi = REAL(x)[i];
            yi = REAL(y)[i];
            GConvert(&xi, &yi, USER, INCHES, dd);
            if (!R_FINITE(xi) || !R_FINITE(yi)) continue;
            d = hypot(xp-xi, yp-yi);
            if (d < dmin) {
                imin = i;
                dmin = d;
            }
          }
          /* can't use warning because we want to print immediately  */
          /* might want to handle warn=2? */
          warn = asInteger(GetOption(install("warn"), R_BaseEnv));
          if (dmin > tol) {
            if(warn >= 0) {
                REprintf(_("warning: no point within %.2f inches\n"), tol);
                R_FlushConsole();
            }
          }
          else if (LOGICAL(ind)[imin]) {
            if(warn >= 0 ) {
                REprintf(_("warning: nearest point already identified\n"));
                R_FlushConsole();
            }
          }
          else {
            k++;
            LOGICAL(ind)[imin] = 1;

            if (atpen) {
                xi = xp;
                yi = yp;
                INTEGER(pos)[imin] = 0;
                /* now record where to replot if necessary */
                GConvert(&xp, &yp, INCHES, USER, dd);
                REAL(x)[imin] = xp; REAL(y)[imin] = yp;
            } else {
                xi = REAL(x)[imin];
                yi = REAL(y)[imin];
                GConvert(&xi, &yi, USER, INCHES, dd);
                if (fabs(xp-xi) >= fabs(yp-yi)) {
                  if (xp >= xi)
                      INTEGER(pos)[imin] = 4;
                  else
                      INTEGER(pos)[imin] = 2;
                } else {
                  if (yp >= yi)
                      INTEGER(pos)[imin] = 3;
                  else
                      INTEGER(pos)[imin] = 1;
                }
            }
            if (plot) {
                drawLabel(xi, yi, INTEGER(pos)[imin], offset,
                        CHAR(STRING_ELT(l, imin % nl)),
                        getCharCE(STRING_ELT(l, imin % nl)), dd);
                GMode(0, dd);
                GMode(2, dd);
            }
          }
      }
      GMode(0, dd);
      PROTECT(ans = allocList(2));
      SETCAR(ans, ind);
      SETCADR(ans, pos);
      PROTECT(saveans = allocList(7));
      SETCAR(saveans, ind);
      SETCADR(saveans, pos);
      SETCADDR(saveans, x);
      SETCADDDR(saveans, y);
      SETCAD4R(saveans, Offset);
      SETCAD4R(CDR(saveans), l);
      SETCAD4R(CDDR(saveans), ScalarLogical(plot));

      /* If we are recording, save enough information to be able to
         redraw the text labels beside identified points */
      if (GRecording(call, dd))
          GErecordGraphicOperation(op, saveans, dd);
      UNPROTECT(6);

      R_Visible = TRUE;
      return ans;
    }
}

/* strheight(str, units, cex, font, vfont, ...)  ||  strwidth() */
#define DO_STR_DIM(KIND)                                    \
{                                                     \
    SEXP ans, str, ch, font, vfont;                         \
    int i, n, units;                                        \
    double cex, cexsave;                                    \
    pGEDevDesc dd = GEcurrentDevice();                            \
                                                      \
    if (length(args) < 5) error(_("too few arguments"));          \
    /* GCheckState(dd); */                                  \
                                                      \
    str = CAR(args);                                        \
    if (isSymbol(str) || isLanguage(str))                   \
      str = coerceVector(str, EXPRSXP);                     \
    else if (!isExpression(str))                            \
      str = coerceVector(str, STRSXP);                      \
    PROTECT(str);                                     \
    args = CDR(args);                                       \
                                                      \
    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)      \
      error(_("invalid units"));                            \
    if(units == 1)  GCheckState(dd); \
    args = CDR(args);                                       \
                                                      \
    if (isNull(CAR(args)))                                  \
      cex = gpptr(dd)->cex;                                 \
    else if (!R_FINITE((cex = asReal(CAR(args)))) || cex <= 0.0)  \
      error(_("invalid '%s' value"), "cex");                      \
    args = CDR(args);                                       \
    PROTECT(font = FixupFont(CAR(args), NA_INTEGER)); args = CDR(args); \
    PROTECT(vfont = FixupVFont(CAR(args))); args = CDR(args);           \
    GSavePars(dd);                                          \
    ProcessInlinePars(args, dd, call);                            \
                                                      \
    /* 'vfont' trumps inline 'family' */                    \
    if (!isNull(vfont) && !isExpression(str)) {                   \
      strncpy(gpptr(dd)->family, "Her ", 201);              \
      gpptr(dd)->family[3] = INTEGER(vfont)[0];             \
      gpptr(dd)->font = INTEGER(vfont)[1];                        \
    } else gpptr(dd)->font = INTEGER(font)[0];                    \
                                                      \
    n = LENGTH(str);                                        \
    PROTECT(ans = allocVector(REALSXP, n));                       \
    cexsave = gpptr(dd)->cex;                               \
    gpptr(dd)->cex = cex * gpptr(dd)->cexbase;                    \
    for (i = 0; i < n; i++)                                 \
      if (isExpression(str))                                \
          REAL(ans)[i] = GExpression ## KIND(VECTOR_ELT(str, i),  \
                                   GMapUnits(units), dd);   \
      else {                                                \
          ch = STRING_ELT(str, i);                          \
          REAL(ans)[i] = (ch == NA_STRING) ? 0.0 :                \
            GStr ## KIND(CHAR(ch), getCharCE(ch), GMapUnits(units), dd);            \
      }                                               \
    gpptr(dd)->cex = cexsave;                               \
    GRestorePars(dd);                                       \
    UNPROTECT(4);                                     \
    return ans;                                             \
}

SEXP attribute_hidden do_strheight(SEXP call, SEXP op, SEXP args, SEXP env)
DO_STR_DIM(Height)

SEXP attribute_hidden do_strwidth (SEXP call, SEXP op, SEXP args, SEXP env)
DO_STR_DIM(Width)

#undef DO_STR_DIM


static int *dnd_lptr;
static int *dnd_rptr;
static double *dnd_hght;
static double *dnd_xpos;
static double dnd_hang;
static double dnd_offset;

static void drawdend(int node, double *x, double *y, SEXP dnd_llabels,
                 pGEDevDesc dd)
{
/* Recursive function for 'hclust' dendrogram drawing:
 * Do left + Do right + Do myself
 * "do" : 1) label leafs (if there are) and __
 *        2) find coordinates to draw the  | |
 *        3) return (*x,*y) of "my anchor"
 */
    double xl, xr, yl, yr;
    double xx[4], yy[4];
    int k;

    *y = dnd_hght[node-1];
    /* left part  */
    k = dnd_lptr[node-1];
    if (k > 0) drawdend(k, &xl, &yl, dnd_llabels, dd);
    else {
      xl = dnd_xpos[-k-1];
      yl = (dnd_hang >= 0) ? *y - dnd_hang : 0;
      if(STRING_ELT(dnd_llabels, -k-1) != NA_STRING)
          GText(xl, yl-dnd_offset, USER,
              CHAR(STRING_ELT(dnd_llabels, -k-1)),
              getCharCE(STRING_ELT(dnd_llabels, -k-1)),
              1.0, 0.3, 90.0, dd);
    }
    /* right part */
    k = dnd_rptr[node-1];
    if (k > 0) drawdend(k, &xr, &yr, dnd_llabels, dd);
    else {
      xr = dnd_xpos[-k-1];
      yr = (dnd_hang >= 0) ? *y - dnd_hang : 0;
      if(STRING_ELT(dnd_llabels, -k-1) != NA_STRING)
          GText(xr, yr-dnd_offset, USER,
              CHAR(STRING_ELT(dnd_llabels, -k-1)),
              getCharCE(STRING_ELT(dnd_llabels, -k-1)),
              1.0, 0.3, 90.0, dd);
    }
    xx[0] = xl; yy[0] = yl;
    xx[1] = xl; yy[1] = *y;
    xx[2] = xr; yy[2] = *y;
    xx[3] = xr; yy[3] = yr;
    GPolyline(4, xx, yy, USER, dd);
    *x = 0.5 * (xl + xr);
}


SEXP attribute_hidden do_dend(SEXP call, SEXP op, SEXP args, SEXP env)
{
    double x, y;
    int n;

    SEXP originalArgs, dnd_llabels, xpos;
    pGEDevDesc dd;

    dd = GEcurrentDevice();
    GCheckState(dd);

    originalArgs = args;
    if (length(args) < 6)
      error(_("too few arguments"));

    /* n */
    n = asInteger(CAR(args));
    if (n == NA_INTEGER || n < 2)
      goto badargs;
    args = CDR(args);

    /* merge */
    if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2*n)
      goto badargs;
    dnd_lptr = &(INTEGER(CAR(args))[0]);
    dnd_rptr = &(INTEGER(CAR(args))[n]);
    args = CDR(args);

    /* height */
    if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
      goto badargs;
    dnd_hght = REAL(CAR(args));
    args = CDR(args);

    /* ord = order(x$order) */
    if (length(CAR(args)) != n+1)
      goto badargs;
    PROTECT(xpos = coerceVector(CAR(args), REALSXP));
    dnd_xpos = REAL(xpos);
    args = CDR(args);

    /* hang */
    dnd_hang = asReal(CAR(args));
    if (!R_FINITE(dnd_hang))
      goto badargs;
    dnd_hang = dnd_hang * (dnd_hght[n-1] - dnd_hght[0]);
    args = CDR(args);

    /* labels */
    if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n+1)
      goto badargs;
    dnd_llabels = CAR(args);
    args = CDR(args);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);
    gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cex;
    dnd_offset = GConvertYUnits(GStrWidth("m", CE_ANY, INCHES, dd), INCHES,
                        USER, dd);

    /* override par("xpd") and force clipping to figure region */
    /* NOTE: don't override to _reduce_ clipping region */
    if (gpptr(dd)->xpd < 1)
      gpptr(dd)->xpd = 1;

    GMode(1, dd);
    drawdend(n, &x, &y, dnd_llabels, dd);
    GMode(0, dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    UNPROTECT(1);
    return R_NilValue;

  badargs:
    error(_("invalid dendrogram input"));
    return R_NilValue;/* never used; to keep -Wall happy */
}

SEXP attribute_hidden do_dendwindow(SEXP call, SEXP op, SEXP args, SEXP env)
{
    int i, imax, n;
    double pin, *ll, tmp, yval, *y, ymin, ymax, yrange, m;
    SEXP originalArgs, merge, height, llabels, str;
    void *vmax;
    pGEDevDesc dd;

    dd = GEcurrentDevice();
    GCheckState(dd);
    originalArgs = args;
    if (length(args) < 5)
      error(_("too few arguments"));
    n = asInteger(CAR(args));
    if (n == NA_INTEGER || n < 2)
      goto badargs;
    args = CDR(args);
    if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2 * n)
      goto badargs;
    merge = CAR(args);

    args = CDR(args);
    if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
      goto badargs;
    height = CAR(args);

    args = CDR(args);
    dnd_hang = asReal(CAR(args));
    if (!R_FINITE(dnd_hang))
      goto badargs;

    args = CDR(args);
    if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n + 1)
      goto badargs;
    llabels = CAR(args);

    args = CDR(args);
    GSavePars(dd);
    ProcessInlinePars(args, dd, call);
    gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cex;
    dnd_offset = GStrWidth("m", CE_ANY, INCHES, dd);
    vmax = vmaxget();
    /* n is the number of merges, so the points are labelled 1 ... n+1 */
    y =  (double*)R_alloc(n+1, sizeof(double));
    ll = (double*)R_alloc(n+1, sizeof(double));
    dnd_lptr = &(INTEGER(merge)[0]);
    dnd_rptr = &(INTEGER(merge)[n]);
    ymax = ymin = REAL(height)[0];
    for (i = 1; i < n; i++) {
      m = REAL(height)[i];
      if (m > ymax)
          ymax = m;
      else if (m < ymin)
          ymin = m;
    }
    pin = gpptr(dd)->pin[1];
    for (i = 0; i <= n; i++) {
      str = STRING_ELT(llabels, i);
      ll[i] = (str == NA_STRING) ? 0.0 :
          GStrWidth(CHAR(str), getCharCE(str), INCHES, dd) + dnd_offset;
    }

    imax = -1; yval = -DBL_MAX;
    if (dnd_hang >= 0) {
      ymin = ymax - (1 + dnd_hang) * (ymax - ymin);
      yrange = ymax - ymin;
      /* determine leaf heights */
      for (i = 0; i < n; i++) {
          if (dnd_lptr[i] < 0)
            y[-dnd_lptr[i] - 1] = REAL(height)[i];
          if (dnd_rptr[i] < 0)
            y[-dnd_rptr[i] - 1] = REAL(height)[i];
      }
      /* determine the most extreme label depth */
      /* assuming that we are using the full plot */
      /* window for the tree itself */
      for (i = 0; i <= n; i++) {
          tmp = ((ymax - y[i]) / yrange) * pin + ll[i];
          if (tmp > yval) {
            yval = tmp;
            imax = i;
          }
      }
    }
    else {
      yrange = ymax;
      for (i = 0; i <= n; i++) {
          tmp = pin + ll[i];
          if (tmp > yval) {
            yval = tmp;
            imax = i;
          }
      }
    }
    /* now determine how much to scale */
    ymin = ymax - (pin/(pin - ll[imax])) * yrange;
    GScale(1.0, n+1.0, 1 /* x */, dd);
    GScale(ymin, ymax, 2 /* y */, dd);
    GMapWin2Fig(dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    vmaxset(vmax);
    return R_NilValue;
  badargs:
    error(_("invalid dendrogram input"));
    return R_NilValue;/* never used; to keep -Wall happy */
}


SEXP attribute_hidden do_erase(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP col;
    int ncol;
    pGEDevDesc dd = GEcurrentDevice();
    checkArity(op, args);
    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
    ncol = LENGTH(col);
    GSavePars(dd);
    GMode(1, dd);
    GRect(0.0, 0.0, 1.0, 1.0, NDC, INTEGER(col)[0], R_TRANWHITE, dd);
    GMode(0, dd);
    GRestorePars(dd);
    UNPROTECT(1);
    return R_NilValue;
}

/* symbols(..) in ../library/base/R/symbols.R  : */

/* utility just computing range() */
static Rboolean SymbolRange(double *x, int n, double *xmax, double *xmin)
{
    int i;
    *xmax = -DBL_MAX;
    *xmin =  DBL_MAX;
    for(i = 0; i < n; i++)
      if (R_FINITE(x[i])) {
          if (*xmax < x[i]) *xmax = x[i];
          if (*xmin > x[i]) *xmin = x[i];
      }
    return(*xmax >= *xmin && *xmin >= 0);
}

static void CheckSymbolPar(SEXP call, SEXP p, int *nr, int *nc)
{
    SEXP dim = getAttrib(p, R_DimSymbol);
    switch(length(dim)) {
    case 0:
      *nr = LENGTH(p);
      *nc = 1;
      break;
    case 1:
      *nr = INTEGER(dim)[0];
      *nc = 1;
      break;
    case 2:
      *nr = INTEGER(dim)[0];
      *nc = INTEGER(dim)[1];
      break;
    default:
      *nr = 0;
      *nc = 0;
    }
    if (*nr == 0 || *nc == 0)
      error(_("invalid symbol parameter vector"));
}

/* Internal  symbols(x, y, type, data, inches, bg, fg, ...) */
SEXP attribute_hidden do_symbols(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, y, p, fg, bg;
    int i, j, nr, nc, nbg, nfg, type;
    double pmax, pmin, inches, rx, ry;
    double xx, yy, p0, p1, p2, p3, p4;
    double *pp, *xp, *yp;
    void *vmax;

    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();
    GCheckState(dd);

    if (length(args) < 7)
      error(_("too few arguments"));

    PROTECT(x = coerceVector(CAR(args), REALSXP)); args = CDR(args);
    PROTECT(y = coerceVector(CAR(args), REALSXP)); args = CDR(args);
    if (!isNumeric(x) || !isNumeric(y) || length(x) <= 0 || LENGTH(x) <= 0)
      error(_("invalid symbol coordinates"));

    type = asInteger(CAR(args)); args = CDR(args);

    /* data: */
    p = PROTECT(coerceVector(CAR(args), REALSXP)); args = CDR(args);
    CheckSymbolPar(call, p, &nr, &nc);
    if (LENGTH(x) != nr || LENGTH(y) != nr)
      error(_("x/y/parameter length mismatch"));

    inches = asReal(CAR(args)); args = CDR(args);
    if (!R_FINITE(inches) || inches < 0)
      inches = 0;

    PROTECT(bg = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
    nbg = LENGTH(bg);

    PROTECT(fg = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
    nfg = LENGTH(fg);

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    GMode(1, dd);
    switch (type) {
    case 1: /* circles */
      if (nc != 1)
          error(_("invalid circles data"));
      if (!SymbolRange(REAL(p), nr, &pmax, &pmin))
          error(_("invalid symbol parameter"));
      for (i = 0; i < nr; i++) {
          if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
            R_FINITE(REAL(p)[i])) {
            rx = REAL(p)[i];
            /* For GCircle the radius is always in INCHES */
            if (inches > 0)
                rx *= inches / pmax;
            else
                rx = GConvertXUnits(rx, USER, INCHES, dd);
            GCircle(REAL(x)[i], REAL(y)[i],     USER, rx,
                  INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg],   dd);
          }
      }
      break;
    case 2: /* squares */
      if(nc != 1)
          error(_("invalid squares data"));
      if(!SymbolRange(REAL(p), nr, &pmax, &pmin))
          error(_("invalid symbol parameter"));
      for (i = 0; i < nr; i++) {
          if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
            R_FINITE(REAL(p)[i])) {
            p0 = REAL(p)[i];
            xx = REAL(x)[i];
            yy = REAL(y)[i];
            GConvert(&xx, &yy, USER, DEVICE, dd);
            if (inches > 0) {
                p0 *= inches / pmax;
                rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
            }
            else {
                rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
            }
            GRect(xx - rx, yy - rx, xx + rx, yy + rx, DEVICE,
                  INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
          }
      }
      break;
    case 3: /* rectangles */
      if (nc != 2)
          error(_("invalid rectangles data (need 2 columns)"));
      if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
          error(_("invalid symbol parameter"));
      for (i = 0; i < nr; i++) {
          if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
            R_FINITE(REAL(p)[i]) && R_FINITE(REAL(p)[i+nr])) {
            xx = REAL(x)[i];
            yy = REAL(y)[i];
            GConvert(&xx, &yy, USER, DEVICE, dd);
            p0 = REAL(p)[i];
            p1 = REAL(p)[i+nr];
            if (inches > 0) {
                p0 *= inches / pmax;
                p1 *= inches / pmax;
                rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
                ry = GConvertYUnits(0.5 * p1, INCHES, DEVICE, dd);
            }
            else {
                rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
                ry = GConvertYUnits(0.5 * p1, USER, DEVICE, dd);
            }
            GRect(xx - rx, yy - ry, xx + rx, yy + ry, DEVICE,
                  INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);

          }
      }
      break;
    case 4: /* stars */
      if (nc < 3)
          error(_("invalid stars data"));
      if (!SymbolRange(REAL(p), nc * nr, &pmax, &pmin))
          error(_("invalid symbol parameter"));
      vmax = vmaxget();
      pp = (double*)R_alloc(nc, sizeof(double));
      xp = (double*)R_alloc(nc, sizeof(double));
      yp = (double*)R_alloc(nc, sizeof(double));
      p1 = 2.0 * M_PI / nc;
      for (i = 0; i < nr; i++) {
          xx = REAL(x)[i];
          yy = REAL(y)[i];
          if (R_FINITE(xx) && R_FINITE(yy)) {
            GConvert(&xx, &yy, USER, NDC, dd);
            if (inches > 0) {
                for(j = 0; j < nc; j++) {
                  p0 = REAL(p)[i + j * nr];
                  if (!R_FINITE(p0)) p0 = 0;
                  pp[j] = (p0 / pmax) * inches;
                }
            }
            else {
                for(j = 0; j < nc; j++) {
                  p0 = REAL(p)[i + j * nr];
                  if (!R_FINITE(p0)) p0 = 0;
                  pp[j] =      GConvertXUnits(p0, USER, INCHES, dd);
                }
            }
            for(j = 0; j < nc; j++) {
                xp[j] = GConvertXUnits(pp[j] * cos(j * p1),
                                 INCHES, NDC, dd) + xx;
                yp[j] = GConvertYUnits(pp[j] * sin(j * p1),
                                 INCHES, NDC, dd) + yy;
            }
            GPolygon(nc, xp, yp, NDC,
                   INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
          }
      }
      vmaxset(vmax);
      break;
    case 5: /* thermometers */
      if (nc != 3 && nc != 4)
          error(_("invalid thermometers data (need 3 or 4 columns)"));
      SymbolRange(REAL(p)+2*nr/* <-- pointer arith*/, nr, &pmax, &pmin);
      if (pmax < pmin)
          error(_("invalid thermometers[,%s]"),
                  (nc == 4)? "3:4" : "3");
      if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
          warning(_("thermometers[,%s] not in [0,1] -- may look funny"),
                (nc == 4)? "3:4" : "3");
      if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
          error(_("invalid thermometers[,1:2]"));
      for (i = 0; i < nr; i++) {
          xx = REAL(x)[i];
          yy = REAL(y)[i];
          if (R_FINITE(xx) && R_FINITE(yy)) {
            p0 = REAL(p)[i];
            p1 = REAL(p)[i + nr];
            p2 = REAL(p)[i + 2 * nr];
            p3 = (nc == 4)? REAL(p)[i + 3 * nr] : 0.;
            if (R_FINITE(p0) && R_FINITE(p1) &&
                R_FINITE(p2) && R_FINITE(p3)) {
                if (p2 < 0) p2 = 0; else if (p2 > 1) p2 = 1;
                if (p3 < 0) p3 = 0; else if (p3 > 1) p3 = 1;
                GConvert(&xx, &yy, USER, NDC, dd);
                if (inches > 0) {
                  p0 *= inches / pmax;
                  p1 *= inches / pmax;
                  rx = GConvertXUnits(0.5 * p0, INCHES, NDC, dd);
                  ry = GConvertYUnits(0.5 * p1, INCHES, NDC, dd);
                }
                else {
                  rx = GConvertXUnits(0.5 * p0, USER, NDC, dd);
                  ry = GConvertYUnits(0.5 * p1, USER, NDC, dd);
                }
                GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
                    INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
                GRect(xx - rx,  yy - (1 - 2 * p2) * ry,
                    xx + rx,  yy - (1 - 2 * p3) * ry,
                    NDC,
                    INTEGER(fg)[i%nfg], INTEGER(fg)[i%nfg], dd);
                GLine(xx - rx, yy, xx - 1.5 * rx, yy, NDC, dd);
                GLine(xx + rx, yy, xx + 1.5 * rx, yy, NDC, dd);

            }
          }
      }
      break;
    case 6: /* boxplots (wid, hei, loWhsk, upWhsk, medProp) */
      if (nc != 5)
          error(_("invalid boxplots data (need 5 columns)"));
      pmax = -DBL_MAX;
      pmin =      DBL_MAX;
      for(i = 0; i < nr; i++) {
          p4 = REAL(p)[i + 4 * nr]; /* median proport. in [0,1] */
          if (pmax < p4) pmax = p4;
          if (pmin > p4) pmin = p4;
      }
      if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
          warning(_("boxplots[,5] outside [0,1] -- may look funny"));
      if (!SymbolRange(REAL(p), 4 * nr, &pmax, &pmin))
          error(_("invalid boxplots[, 1:4]"));
      for (i = 0; i < nr; i++) {
          xx = REAL(x)[i];
          yy = REAL(y)[i];
          if (R_FINITE(xx) && R_FINITE(yy)) {
            p0 = REAL(p)[i];  /* width */
            p1 = REAL(p)[i + nr];   /* height */
            p2 = REAL(p)[i + 2 * nr];/* lower whisker */
            p3 = REAL(p)[i + 3 * nr];/* upper whisker */
            p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */
            if (R_FINITE(p0) && R_FINITE(p1) &&
                R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {
                GConvert(&xx, &yy, USER, NDC, dd);
                if (inches > 0) {
                  p0 *= inches / pmax;
                  p1 *= inches / pmax;
                  p2 *= inches / pmax;
                  p3 *= inches / pmax;
                  p0 = GConvertXUnits(p0, INCHES, NDC, dd);
                  p1 = GConvertYUnits(p1, INCHES, NDC, dd);
                  p2 = GConvertYUnits(p2, INCHES, NDC, dd);
                  p3 = GConvertYUnits(p3, INCHES, NDC, dd);
                }
                else {
                  p0 = GConvertXUnits(p0, USER, NDC, dd);
                  p1 = GConvertYUnits(p1, USER, NDC, dd);
                  p2 = GConvertYUnits(p2, USER, NDC, dd);
                  p3 = GConvertYUnits(p3, USER, NDC, dd);
                }
                rx = 0.5 * p0;
                ry = 0.5 * p1;
                p4 = (1 - p4) * (yy - ry) + p4 * (yy + ry);
                /* Box */
                GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
                    INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
                /* Median */
                GLine(xx - rx, p4, xx + rx, p4, NDC, dd);
                /* Lower Whisker */
                GLine(xx, yy - ry, xx, yy - ry - p2, NDC, dd);
                /* Upper Whisker */
                GLine(xx, yy + ry, xx, yy + ry + p3, NDC, dd);
            }
          }
      }
      break;
    default:
      error(_("invalid symbol type"));
    }
    GMode(0, dd);
    GRestorePars(dd);
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    UNPROTECT(5);
    return R_NilValue;
}

SEXP attribute_hidden do_xspline(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP sx, sy, ss, col, border, res, ans = R_NilValue;
    int i, nx;
    int ncol, nborder;
    double *x, *y;
    Rboolean open, repEnds, draw;
    double *xx;
    double *yy;
    void *vmaxsave;
    R_GE_gcontext gc;

    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();
    gcontextFromGP(&gc, dd);

    GCheckState(dd);

    if (length(args) < 6) error(_("too few arguments"));
    /* (x,y) is checked in R via xy.coords() ; no need here : */
    sx = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
    sy = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
    nx = LENGTH(sx);
    ss = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
    open = asLogical(CAR(args)); args = CDR(args);
    repEnds = asLogical(CAR(args)); args = CDR(args);
    draw = asLogical(CAR(args)); args = CDR(args);

    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));  args = CDR(args);
    ncol = LENGTH(col);
    if(ncol < 1)
      error(_("incorrect length for '%s' argument"), "col");
    if(ncol > 1)
      warning(_("incorrect length for '%s' argument"), "col");

    PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg)); args = CDR(args);
    nborder = LENGTH(border);
    if(nborder < 1)
      error(_("incorrect length for '%s' argument"), "border");
    if(nborder > 1)
      warning(_("incorrect length for '%s' argument"), "border");

    GSavePars(dd);
    ProcessInlinePars(args, dd, call);

    GMode(1, dd);

    x = REAL(sx);
    y = REAL(sy);
    vmaxsave = vmaxget();
    xx = (double *) R_alloc(nx, sizeof(double));
    yy = (double *) R_alloc(nx, sizeof(double));
    if (!xx || !yy)
      error(_("unable to allocate memory (in do_xspline)"));
    for (i = 0; i < nx; i++) {
      xx[i] = x[i];
      yy[i] = y[i];
      GConvert(&(xx[i]), &(yy[i]), USER, DEVICE, dd);
    }
    GClip(dd);
    gc.col = INTEGER(border)[0];
    gc.fill = INTEGER(col)[0];
    res = GEXspline(nx, xx, yy, REAL(ss), open, repEnds, draw, &gc, dd);
    vmaxset(vmaxsave);
    UNPROTECT(2);

    if(!draw) {
      SEXP nm, tmpx, tmpy;
      double *xx, *yy, *x0, *y0;
      PROTECT(ans = res);
      PROTECT(nm = allocVector(STRSXP, 2));
      SET_STRING_ELT(nm, 0, mkChar("x"));
      SET_STRING_ELT(nm, 1, mkChar("y"));
      setAttrib(ans, R_NamesSymbol, nm);
      nx = LENGTH(VECTOR_ELT(ans, 0));
      x0 = REAL(VECTOR_ELT(ans, 0));
      y0 = REAL(VECTOR_ELT(ans, 1));
      PROTECT(tmpx = allocVector(REALSXP, nx));
      PROTECT(tmpy = allocVector(REALSXP, nx));
      xx = REAL(tmpx);
      yy = REAL(tmpy);
      for (i = 0; i < nx; i++) {
          xx[i] = x0[i];
          yy[i] = y0[i];
          GConvert(&(xx[i]), &(yy[i]), DEVICE, USER, dd);
      }
      SET_VECTOR_ELT(ans, 0, tmpx);
      SET_VECTOR_ELT(ans, 1, tmpy);
      UNPROTECT(4);
    }

    GMode(0, dd);
    GRestorePars(dd);
    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return ans;
}

/* clip(x1, x2, y1, y2) */
SEXP attribute_hidden do_clip(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans = R_NilValue;
    double x1, x2, y1, y2;
    SEXP originalArgs = args;
    pGEDevDesc dd = GEcurrentDevice();

    checkArity(op, args);
    x1 = asReal(CAR(args));
    if(!R_FINITE(x1)) error("invalid '%s' argument", "x1");
    args = CDR(args);
    x2 = asReal(CAR(args));
    if(!R_FINITE(x2)) error("invalid '%s' argument", "x2");
    args = CDR(args);
    y1 = asReal(CAR(args));
    if(!R_FINITE(y1)) error("invalid '%s' argument", "y1");
    args = CDR(args);
    y2 = asReal(CAR(args));
    if(!R_FINITE(y2)) error("invalid '%s' argument", "y2");

    GConvert(&x1, &y1, USER, DEVICE, dd);
    GConvert(&x2, &y2, USER, DEVICE, dd);
    GESetClip(x1, y1, x2, y2, dd);

    /* NOTE: only record operation if no "error"  */
    if (GRecording(call, dd))
      GErecordGraphicOperation(op, originalArgs, dd);
    return ans;
}

/* convert[XY](x, from to) */
SEXP attribute_hidden do_convertXY(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans = R_NilValue, x;
    int from, to, i, n;
    double *rx;
    pGEDevDesc gdd = GEcurrentDevice();

    checkArity(op, args);
    x = CAR(args);
    if (TYPEOF(x) != REALSXP) error(_("invalid '%s' argument"), "x");
    n = LENGTH(x);
    from = asInteger(CADR(args));
    if (from == NA_INTEGER || from <= 0 || from > 17 )
      error(_("invalid '%s' argument"), "from");
    to = asInteger(CADDR(args));
    if (to == NA_INTEGER || to <= 0 || to > 17 )
      error(_("invalid '%s' argument"), "to");
    from--; to--;

    PROTECT(ans = duplicate(x));
    rx = REAL(ans);
    if (PRIMVAL(op) == 1)
      for (i = 0; i < n; i++) rx[i] = GConvertY(rx[i], from, to, gdd);
    else
      for (i = 0; i < n; i++) rx[i] = GConvertX(rx[i], from, to, gdd);
    UNPROTECT(1);

    return ans;
}

Generated by  Doxygen 1.6.0   Back to index