/src/r-source/src/main/altclasses.c

Source
/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2016--2026   The R Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */

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

#include <Defn.h>
#include <R_ext/Altrep.h>
#include <float.h> /* for DBL_DIG */
#include <Print.h> /* for R_print */
#include <R_ext/Itermacros.h>

#ifdef Win32
#include <trioremap.h> /* for %lld */
#endif


/***
 *** ALTREP Concrete Class Implementations
 ***/

/**
 ** Compact Integer Sequences
 **/

/*
 * Methods
 */

#define COMPACT_SEQ_INFO(x) R_altrep_data1(x)
#define COMPACT_SEQ_EXPANDED(x) R_altrep_data2(x)
#define SET_COMPACT_SEQ_EXPANDED(x, v) R_set_altrep_data2(x, v)

/* needed for now for objects serialized with INTSXP state */
#define COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(info) \
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[0] : (R_xlen_t) REAL0(info)[0])
#define COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(info) \
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[1] : (int) REAL0(info)[1])
#define COMPACT_INTSEQ_SERIALIZED_STATE_INCR(info) \
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[2] : (int) REAL0(info)[2])

/* info is stored as REALSXP to allow for long vector length */
#define COMPACT_INTSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
#define COMPACT_INTSEQ_INFO_FIRST(info) ((int) REAL0(info)[1])
#define COMPACT_INTSEQ_INFO_INCR(info) ((int) REAL0(info)[2])

/* By default, compact integer sequences are marked as not mutable at
   creation time. Thus even when expanded the expanded data will
   correspond to the original integer sequence (unless it runs into
   mis-behaving C code). If COMPACT_INTSEQ_MUTABLE is defined, then
   the sequence is not marked as not mutable. Once the DATAPTR has
   been requested and releases, the expanded data might be modified by
   an assignment and no longer correspond to the original sequence. */
//#define COMPACT_INTSEQ_MUTABLE

static SEXP compact_intseq_Serialized_state(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* This drops through to standard serialization for expanded
       compact vectors */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return NULL;
#endif
    return COMPACT_SEQ_INFO(x);
}

static SEXP new_compact_intseq(R_xlen_t, int, int);
static SEXP new_compact_realseq(R_xlen_t, double, double);

static SEXP compact_intseq_Unserialize(SEXP class, SEXP state)
{
    /* state is the serialized info vector (see compact_intseq_Serialized_state):
       a numeric vector of length 3.  A crafted serialized stream can supply
       any object here, so reject a malformed state with a clean error rather
       than reading REAL0/INTEGER0 off the end of a short or wrong-typed
       (or non-vector) object. */
    if ((TYPEOF(state) != REALSXP && TYPEOF(state) != INTSXP) ||
  XLENGTH(state) < 3)
  error("invalid compact_intseq serialized state");

    R_xlen_t n = COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(state);
    int n1 = COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(state);
    int inc = COMPACT_INTSEQ_SERIALIZED_STATE_INCR(state);

    if (inc == 1)
  return new_compact_intseq(n, n1,  1);
    else if (inc == -1)
  return new_compact_intseq(n, n1,  -1);
    else
  error("compact sequences with increment %d not supported yet", inc);
}
 
static SEXP compact_intseq_Coerce(SEXP x, int type)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* This drops through to standard coercion for expanded compact
       vectors */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return NULL;
#endif
    if (type == REALSXP) {
  SEXP info = COMPACT_SEQ_INFO(x);
  R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
  int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
  int inc = COMPACT_INTSEQ_INFO_INCR(info);
  return new_compact_realseq(n, n1, inc);
    }
    else return NULL;
}

static SEXP compact_intseq_Duplicate(SEXP x, Rboolean deep)
{
    R_xlen_t n = XLENGTH(x);
    SEXP val = allocVector(INTSXP, n);
    INTEGER_GET_REGION(x, 0, n, INTEGER0(val));
    return val;
}

static
Rboolean compact_intseq_Inspect(SEXP x, int pre, int deep, int pvec,
        void (*inspect_subtree)(SEXP, int, int, int))
{
    int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
    if (inc != 1 && inc != -1)
  error("compact sequences with increment %d not supported yet", inc);

#ifdef COMPACT_INTSEQ_MUTABLE
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue) {
  Rprintf("  <expanded compact integer sequence>\n");
  inspect_subtree(COMPACT_SEQ_EXPANDED(x), pre, deep, pvec);
  return TRUE;
    }
#endif

    R_xlen_t n = XLENGTH(x); // int .. LENGTH(.) not ok, e.g. for -1e9:2e9
    int n1 = INTEGER_ELT(x, 0);
    int n2 = (int) ((inc == 1) ? n1 + n - 1 : n1 - n + 1);
    Rprintf(" %d : %d (%s)", n1, n2,
      COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
    Rprintf("\n");
    return TRUE;
}

static R_INLINE R_xlen_t compact_intseq_Length(SEXP x)
{
    SEXP info = COMPACT_SEQ_INFO(x);
    return COMPACT_INTSEQ_INFO_LENGTH(info);
}

static void *compact_intseq_Dataptr(SEXP x, Rboolean writeable)
{
    if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
  /* no need to re-run if expanded data exists */
  PROTECT(x);
  SEXP info = COMPACT_SEQ_INFO(x);
  R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
  int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
  int inc = COMPACT_INTSEQ_INFO_INCR(info);
  SEXP val = allocVector(INTSXP, n);
  int *data = INTEGER(val);

  if (inc == 1) {
      /* compact sequences n1 : n2 with n1 <= n2 */
      for (R_xlen_t i = 0; i < n; i++)
    data[i] = (int) (n1 + i);
  }
  else if (inc == -1) {
      /* compact sequences n1 : n2 with n1 > n2 */
      for (R_xlen_t i = 0; i < n; i++)
    data[i] = (int) (n1 - i);
  }
  else
      error("compact sequences with increment %d not supported yet", inc);

  SET_COMPACT_SEQ_EXPANDED(x, val);
  UNPROTECT(1);
    }
    return DATAPTR_RW(COMPACT_SEQ_EXPANDED(x));
}

static const void *compact_intseq_Dataptr_or_null(SEXP x)
{
    SEXP val = COMPACT_SEQ_EXPANDED(x);
    return val == R_NilValue ? NULL : DATAPTR_RO(val);
}

static int compact_intseq_Elt(SEXP x, R_xlen_t i)
{
    SEXP ex = COMPACT_SEQ_EXPANDED(x);
    if (ex != R_NilValue)
  return INTEGER0(ex)[i];
    else {
  SEXP info = COMPACT_SEQ_INFO(x);
  int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
  int inc = COMPACT_INTSEQ_INFO_INCR(info);
  return (int) (n1 + inc * i);
    }
}

#define CHECK_NOT_EXPANDED(x)         \
    if (DATAPTR_OR_NULL(x) != NULL)       \
  error("method should only handle unexpanded vectors")

static R_xlen_t
compact_intseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    /* should not get here if x is already expanded */
    CHECK_NOT_EXPANDED(sx);

    SEXP info = COMPACT_SEQ_INFO(sx);
    R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
    R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
    int inc = COMPACT_INTSEQ_INFO_INCR(info);

    R_xlen_t ncopy = size - i > n ? n : size - i;
    if (inc == 1) {
  for (R_xlen_t k = 0; k < ncopy; k++)
      buf[k] = (int) (n1 + k + i);
  return ncopy;
    }
    else if (inc == -1) {
  for (R_xlen_t k = 0; k < ncopy; k++)
      buf[k] = (int) (n1 - k - i);
  return ncopy;
    }
    else
  error("compact sequences with increment %d not supported yet", inc);
}

static int compact_intseq_Is_sorted(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return UNKNOWN_SORTEDNESS;
#endif
    int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
    return inc < 0 ? SORTED_DECR : SORTED_INCR;
}

static int compact_intseq_No_NA(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return FALSE;
#endif
    return TRUE;
}

/* XXX this also appears in summary.c. move to header file?*/
#define R_INT_MIN (1 + INT_MIN)

static SEXP compact_intseq_Sum(SEXP x, Rboolean narm)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue) 
  return NULL;
#endif
    double tmp;
    SEXP info = COMPACT_SEQ_INFO(x);
    R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
    R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
    int inc = COMPACT_INTSEQ_INFO_INCR(info);
    tmp = (size / 2.0) * (n1 + n1 + inc * (size - 1));
    if(tmp > INT_MAX || tmp < R_INT_MIN)
  /**** check for overflow of exact integer range? */
  return ScalarReal(tmp);
    else
  return ScalarInteger((int) tmp);
}


/*
 * Class Objects and Method Tables
 */

R_altrep_class_t R_compact_intseq_class;

static void InitCompactIntegerClass(void)
{
    R_altrep_class_t cls = R_make_altinteger_class("compact_intseq", "base",
               NULL);
    R_compact_intseq_class = cls;

    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, compact_intseq_Unserialize);
    R_set_altrep_Serialized_state_method(cls, compact_intseq_Serialized_state);
    R_set_altrep_Duplicate_method(cls, compact_intseq_Duplicate);
    R_set_altrep_Coerce_method(cls, compact_intseq_Coerce);
    R_set_altrep_Inspect_method(cls, compact_intseq_Inspect);
    R_set_altrep_Length_method(cls, compact_intseq_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, compact_intseq_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, compact_intseq_Dataptr_or_null);

    /* override ALTINTEGER methods */
    R_set_altinteger_Elt_method(cls, compact_intseq_Elt);
    R_set_altinteger_Get_region_method(cls, compact_intseq_Get_region);
    R_set_altinteger_Is_sorted_method(cls, compact_intseq_Is_sorted);
    R_set_altinteger_No_NA_method(cls, compact_intseq_No_NA);
    R_set_altinteger_Sum_method(cls, compact_intseq_Sum);
}


/*
 * Constructor
 */

static SEXP new_compact_intseq(R_xlen_t n, int n1, int inc)
{
    if (n == 1) return ScalarInteger(n1);

    if (inc != 1 && inc != -1)
  error("compact sequences with increment %d not supported yet", inc);

    /* info used REALSXP to allow for long vectors */
    SEXP info = allocVector(REALSXP, 3);
    REAL0(info)[0] = (double) n;
    REAL0(info)[1] = (double) n1;
    REAL0(info)[2] = (double) inc;

    SEXP ans = R_new_altrep(R_compact_intseq_class, info, R_NilValue);
#ifndef COMPACT_INTSEQ_MUTABLE
    MARK_NOT_MUTABLE(ans); /* force duplicate on modify */
#endif

    return ans;
}

attribute_hidden Rboolean R_is_compact_intseq(SEXP x)
{
    return R_altrep_inherits(x, R_compact_intseq_class);
}


/**
 ** Compact Real Sequences
 **/

/*
 * Methods
 */

#define COMPACT_REALSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
#define COMPACT_REALSEQ_INFO_FIRST(info) REAL0(info)[1]
#define COMPACT_REALSEQ_INFO_INCR(info) REAL0(info)[2]

static SEXP compact_realseq_Serialized_state(SEXP x)
{
    return COMPACT_SEQ_INFO(x);
}

static SEXP compact_realseq_Unserialize(SEXP class, SEXP state)
{
    /* as for compact_intseq_Unserialize: the info vector read below is a
       length-3 REALSXP, but a crafted stream can supply anything, so reject
       a malformed state rather than reading REAL0 off the end. */
    if (TYPEOF(state) != REALSXP || XLENGTH(state) < 3)
  error("invalid compact_realseq serialized state");

    double inc = COMPACT_REALSEQ_INFO_INCR(state);
    R_xlen_t len = COMPACT_REALSEQ_INFO_LENGTH(state);
    double n1 = COMPACT_REALSEQ_INFO_FIRST(state);

    if (inc == 1)
  return new_compact_realseq(len, n1,  1);
    else if (inc == -1)
  return new_compact_realseq(len, n1, -1);
    else
  error("compact sequences with increment %f not supported yet", inc);
}

static SEXP compact_realseq_Duplicate(SEXP x, Rboolean deep)
{
    R_xlen_t n = XLENGTH(x);
    SEXP val = allocVector(REALSXP, n);
    REAL_GET_REGION(x, 0, n, REAL0(val));
    return val;
}

static
Rboolean compact_realseq_Inspect(SEXP x, int pre, int deep, int pvec,
         void (*inspect_subtree)(SEXP, int, int, int))
{
    double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
    if (inc != 1 && inc != -1)
  error("compact sequences with increment %f not supported yet", inc);

    R_xlen_t n = XLENGTH(x);
    R_xlen_t n1 = (R_xlen_t) REAL_ELT(x, 0);
    R_xlen_t n2 = inc == 1 ? n1 + n - 1 : n1 - n + 1;
    Rprintf(" %lld : %lld (%s)", (long long)n1, (long long)n2,
      COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
    Rprintf("\n");
    return TRUE;
}

static R_INLINE R_xlen_t compact_realseq_Length(SEXP x)
{
    return (R_xlen_t) REAL0(COMPACT_SEQ_INFO(x))[0];
}

static void *compact_realseq_Dataptr(SEXP x, Rboolean writeable)
{
    if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
  PROTECT(x);
  SEXP info = COMPACT_SEQ_INFO(x);
  R_xlen_t n = COMPACT_REALSEQ_INFO_LENGTH(info);
  double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
  double inc = COMPACT_REALSEQ_INFO_INCR(info);
  
  SEXP val = allocVector(REALSXP, (R_xlen_t) n);
  double *data = REAL(val);

  if (inc == 1) {
      /* compact sequences n1 : n2 with n1 <= n2 */
      for (R_xlen_t i = 0; i < n; i++)
    data[i] = n1 + i;
  }
  else if (inc == -1) {
      /* compact sequences n1 : n2 with n1 > n2 */
      for (R_xlen_t i = 0; i < n; i++)
    data[i] = n1 - i;
  }
  else
      error("compact sequences with increment %f not supported yet", inc);

  SET_COMPACT_SEQ_EXPANDED(x, val);
  UNPROTECT(1);
    }
    return DATAPTR_RW(COMPACT_SEQ_EXPANDED(x));
}

static const void *compact_realseq_Dataptr_or_null(SEXP x)
{
    SEXP val = COMPACT_SEQ_EXPANDED(x);
    return val == R_NilValue ? NULL : DATAPTR_RO(val);
}

static double compact_realseq_Elt(SEXP x, R_xlen_t i)
{
    SEXP ex = COMPACT_SEQ_EXPANDED(x);
    if (ex != R_NilValue)
  return REAL0(ex)[i];
    else {
  SEXP info = COMPACT_SEQ_INFO(x);
  double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
  double inc = COMPACT_REALSEQ_INFO_INCR(info);
  return n1 + inc * i;
    }
}

static R_xlen_t
compact_realseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
{
    /* should not get here if x is already expanded */
    CHECK_NOT_EXPANDED(sx);

    SEXP info = COMPACT_SEQ_INFO(sx);
    R_xlen_t size = COMPACT_REALSEQ_INFO_LENGTH(info);
    double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
    double inc = COMPACT_REALSEQ_INFO_INCR(info);

    R_xlen_t ncopy = size - i > n ? n : size - i;
    if (inc == 1) {
  for (R_xlen_t k = 0; k < ncopy; k++)
      buf[k] = n1 + k + i;
  return ncopy;
    }
    else if (inc == -1) {
  for (R_xlen_t k = 0; k < ncopy; k++)
      buf[k] = n1 - k - i;
  return ncopy;
    }
    else
  error("compact sequences with increment %f not supported yet", inc);
}
    
static int compact_realseq_Is_sorted(SEXP x)
{
#ifdef COMPACT_REALSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return UNKNOWN_SORTEDNESS;
#endif
    double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
    return inc < 0 ? SORTED_DECR : SORTED_INCR;
}

static int compact_realseq_No_NA(SEXP x)
{
#ifdef COMPACT_REALSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
  return FALSE;
#endif
    return TRUE;
}

static SEXP compact_realseq_Sum(SEXP x, Rboolean narm)
{
#ifdef COMPACT_INTSEQ_MUTABLE
    /* If the vector has been expanded it may have been modified. */
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue) 
  return NULL;
#endif
    SEXP info = COMPACT_SEQ_INFO(x);
    double size = (double) COMPACT_REALSEQ_INFO_LENGTH(info);
    double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
    double inc = COMPACT_REALSEQ_INFO_INCR(info);
    return ScalarReal((size / 2.0) *(n1 + n1 + inc * (size - 1)));
}


/*
 * Class Objects and Method Tables
 */


R_altrep_class_t R_compact_realseq_class;

static void InitCompactRealClass(void)
{
    R_altrep_class_t cls = R_make_altreal_class("compact_realseq", "base",
            NULL);
    R_compact_realseq_class = cls;

    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, compact_realseq_Unserialize);
    R_set_altrep_Serialized_state_method(cls, compact_realseq_Serialized_state);
    R_set_altrep_Duplicate_method(cls, compact_realseq_Duplicate);
    R_set_altrep_Inspect_method(cls, compact_realseq_Inspect);
    R_set_altrep_Length_method(cls, compact_realseq_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, compact_realseq_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, compact_realseq_Dataptr_or_null);

    /* override ALTREAL methods */
    R_set_altreal_Elt_method(cls, compact_realseq_Elt);
    R_set_altreal_Get_region_method(cls, compact_realseq_Get_region);
    R_set_altreal_Is_sorted_method(cls, compact_realseq_Is_sorted);
    R_set_altreal_No_NA_method(cls, compact_realseq_No_NA);
    R_set_altreal_Sum_method(cls, compact_realseq_Sum);
}


/*
 * Constructor
 */

static SEXP new_compact_realseq(R_xlen_t n, double n1, double inc)
{
    if (n == 1) return ScalarReal(n1);

    if (inc != 1 && inc != -1)
  error("compact sequences with increment %f not supported yet", inc);

    SEXP info = allocVector(REALSXP, 3);
    REAL(info)[0] = n;
    REAL(info)[1] = n1;
    REAL(info)[2] = inc;

    SEXP ans = R_new_altrep(R_compact_realseq_class, info, R_NilValue);
    MARK_NOT_MUTABLE(ans); /* force duplicate on modify */

    return ans;
}


/**
 ** Compact Integer/Real Sequences
 **/

attribute_hidden SEXP R_compact_intrange(R_xlen_t n1, R_xlen_t n2)
{
    R_xlen_t n = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;

    if (n >= R_XLEN_T_MAX)
  error("result would be too long a vector");

    if (n1 <= INT_MIN || n1 > INT_MAX || n2 <= INT_MIN || n2 > INT_MAX)
  return new_compact_realseq(n, n1, n1 <= n2 ? 1 : -1);
    else
  return new_compact_intseq(n, (int) n1, n1 <= n2 ? 1 : -1);
}


/**
 ** Deferred String Coercions
 **/

/*
 * Methods
 */

#define DEFERRED_STRING_STATE(x) R_altrep_data1(x)
#define CLEAR_DEFERRED_STRING_STATE(x) R_set_altrep_data1(x, R_NilValue)
#define DEFERRED_STRING_EXPANDED(x) R_altrep_data2(x)
#define SET_DEFERRED_STRING_EXPANDED(x, v) R_set_altrep_data2(x, v)

#define MAKE_DEFERRED_STRING_STATE(v, sp) CONS(v, sp)
#define DEFERRED_STRING_STATE_ARG(s) CAR(s)
#define DEFERRED_STRING_STATE_INFO(s) CDR(s)

#define DEFERRED_STRING_ARG(x) \
    DEFERRED_STRING_STATE_ARG(DEFERRED_STRING_STATE(x))
#define DEFERRED_STRING_INFO(x) \
    DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x))
#define DEFERRED_STRING_SCIPEN(x) \
    INTEGER0(DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x)))[0]

/* work-around for package code that mutates things it shouldn't and
   makes serialize and inspect infinite-loop */
#define DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state) do {     \
  if (state != R_NilValue && ATTRIB(CAR(state)) != R_NilValue) { \
      SETCAR(state, shallow_duplicate(CAR(state)));    \
      SET_ATTRIB(CAR(state), R_NilValue);       \
  }               \
    } while (0)
    
static SEXP R_OutDecSym = NULL;

static R_INLINE const char *DEFERRED_STRING_OUTDEC(SEXP x)
{
    /* The default value of OutDec at startup is ".". If it is
       something different at the time the deferred string conversion
       is created then the current value is stored as an attribute. */
    if (R_OutDecSym == NULL)
  R_OutDecSym = install("OutDec");
    SEXP info = DEFERRED_STRING_INFO(x);
    if (ATTRIB(info) != R_NilValue) {
  SEXP outdecattr = getAttrib(info, R_OutDecSym);
  if (TYPEOF(outdecattr) == STRSXP && XLENGTH(outdecattr) == 1)
      return CHAR(STRING_ELT(outdecattr, 0));
    }
    return ".";
}

static SEXP deferred_string_Serialized_state(SEXP x)
{
    /* This drops through to standard serialization for fully expanded
       deferred string conversions. Partial expansions are OK since
       they still correspond to the original data. An assignment to
       the object will access the DATAPTR and force a full expansion
       and dropping the original data. */
    SEXP state = DEFERRED_STRING_STATE(x);
    DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
    return state != R_NilValue ? state : NULL;
}

static SEXP deferred_string_Unserialize(SEXP class, SEXP state)
{
    SEXP arg = DEFERRED_STRING_STATE_ARG(state);
    SEXP info = DEFERRED_STRING_STATE_INFO(state);
    return R_deferred_coerceToString(arg, info);
}

static
Rboolean deferred_string_Inspect(SEXP x, int pre, int deep, int pvec,
         void (*inspect_subtree)(SEXP, int, int, int))
{
    SEXP state = DEFERRED_STRING_STATE(x);
    if (state != R_NilValue) {
  DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
  SEXP arg = DEFERRED_STRING_STATE_ARG(state);
  Rprintf("  <deferred string conversion>\n");
  inspect_subtree(arg, pre, deep, pvec);
    }
    else {
  Rprintf("  <expanded string conversion>\n");
  inspect_subtree(DEFERRED_STRING_EXPANDED(x), pre, deep, pvec);
    }
    return TRUE;
}

static R_INLINE R_xlen_t deferred_string_Length(SEXP x)
{
    SEXP state = DEFERRED_STRING_STATE(x);
    return state == R_NilValue ?
  XLENGTH(DEFERRED_STRING_EXPANDED(x)) :
  XLENGTH(DEFERRED_STRING_STATE_ARG(state));
}

static R_INLINE SEXP ExpandDeferredStringElt(SEXP x, R_xlen_t i)
{
    /* make sure the STRSXP for the expanded string is allocated */
    /* not yet expanded strings are NULL in the STRSXP */
    SEXP val = DEFERRED_STRING_EXPANDED(x);
    if (val == R_NilValue) {
  R_xlen_t n = XLENGTH(x);
  val = allocVector(STRSXP, n);
  if (n)
      memset(STDVEC_DATAPTR(val), 0, n * sizeof(SEXP));
  SET_DEFERRED_STRING_EXPANDED(x, val);
    }

    SEXP elt = STRING_ELT(val, i);
    if (elt == NULL) {
  int warn; /* not used by the coercion functions */
  int savedigits, savescipen;
  SEXP data = DEFERRED_STRING_ARG(x);
  switch(TYPEOF(data)) {
  case INTSXP:
      elt = StringFromInteger(INTEGER_ELT(data, i), &warn);
      break;
  case REALSXP:
      savedigits = R_print.digits;
      savescipen = R_print.scipen;
      R_print.digits = DBL_DIG;/* MAX precision */
      R_print.scipen = DEFERRED_STRING_SCIPEN(x);
      const char *myoutdec = DEFERRED_STRING_OUTDEC(x);
      if (strcmp(OutDec, myoutdec)) {
    /* The current and saved OutDec values differ. The
       value to use is put in a static buffer and OutDec
       temporarily points to this buffer while
       StringFromReal is called and then reset. The buffer
       originally pointed to by OutDec cannot be used as
       it wil not be writable if the default "." has not
       been changed. */
    static char buf[10];
    strncpy(buf, myoutdec, sizeof buf);
    buf[sizeof(buf) - 1] = '\0';
    char *savedOutDec = OutDec;
    OutDec = buf;
    elt = StringFromReal(REAL_ELT(data, i), &warn);
    OutDec = savedOutDec;
      }
      else
    elt = StringFromReal(REAL_ELT(data, i), &warn);
      R_print.digits = savedigits;
      R_print.scipen = savescipen;
      break;
  default:
      error("unsupported type for deferred string coercion");
  }
  SET_STRING_ELT(val, i, elt);
    }
    return elt;
}

static R_INLINE void expand_deferred_string(SEXP x)
{
    SEXP state = DEFERRED_STRING_STATE(x);
    if (state != R_NilValue) {
  /* expanded data may be incomplete until original data is removed */
  PROTECT(x);
  R_xlen_t n = XLENGTH(x), i;
  if (n == 0)
      SET_DEFERRED_STRING_EXPANDED(x, allocVector(STRSXP, 0));
  else
      for (i = 0; i < n; i++)
    ExpandDeferredStringElt(x, i);
  CLEAR_DEFERRED_STRING_STATE(x); /* allow arg to be reclaimed */
  UNPROTECT(1);
    }
}

static void *deferred_string_Dataptr(SEXP x, Rboolean writeable)
{
    expand_deferred_string(x);
    return DATAPTR_RW(DEFERRED_STRING_EXPANDED(x));
}

static const void *deferred_string_Dataptr_or_null(SEXP x)
{
    SEXP state = DEFERRED_STRING_STATE(x);
    return state != R_NilValue ? NULL : DATAPTR_RO(DEFERRED_STRING_EXPANDED(x));
}

static SEXP deferred_string_Elt(SEXP x, R_xlen_t i)
{
    SEXP state = DEFERRED_STRING_STATE(x);
    if (state == R_NilValue)
  /* string is fully expanded */
  return STRING_ELT(DEFERRED_STRING_EXPANDED(x), i);
    else {
  /* expand only the requested element */
  PROTECT(x);
  SEXP elt = ExpandDeferredStringElt(x, i);
  UNPROTECT(1);
  return elt;
    }
}

static void deferred_string_Set_elt(SEXP x, R_xlen_t i, SEXP v)
{
    expand_deferred_string(x);
    SET_STRING_ELT(DEFERRED_STRING_EXPANDED(x), i, v);
}

static int deferred_string_Is_sorted(SEXP x)
{
    /* same as the default method; sortedness of the numeric is not relevant  */
    return UNKNOWN_SORTEDNESS;
}

static int deferred_string_No_NA(SEXP x)
{
    SEXP state = DEFERRED_STRING_STATE(x);
    if (state == R_NilValue)
  /* string is fully expanded and may have been modified. */
  return FALSE;
    else {
  /* defer to the argument */
  SEXP arg = DEFERRED_STRING_STATE_ARG(state);
  switch(TYPEOF(arg)) {
  case INTSXP: return INTEGER_NO_NA(arg);
  case REALSXP: return REAL_NO_NA(arg);
  default: return FALSE;
  }
    }
}

static SEXP deferred_string_Extract_subset(SEXP x, SEXP indx, SEXP call)
{
    SEXP result = NULL;

    if (! OBJECT(x) && ATTRIB(x) == R_NilValue &&
  DEFERRED_STRING_STATE(x) != R_NilValue) {
  /* For deferred string coercions, create a new conversion
     using the subset of the argument.  Could try to
     preserve/share coercions already done, if there are any. */
  SEXP data = DEFERRED_STRING_ARG(x);
  SEXP info = DEFERRED_STRING_INFO(x);
  PROTECT(result = ExtractSubset(data, indx, call));
  result = R_deferred_coerceToString(result, info);
  UNPROTECT(1);
  return result;
    }

    return result;
}


/*
 * Class Object and Method Table
 */

static R_altrep_class_t R_deferred_string_class;

static void InitDefferredStringClass(void)
{
    R_altrep_class_t cls = R_make_altstring_class("deferred_string", "base",
              NULL);
    R_deferred_string_class = cls;

    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, deferred_string_Unserialize);
    R_set_altrep_Serialized_state_method(cls, deferred_string_Serialized_state);
    R_set_altrep_Inspect_method(cls, deferred_string_Inspect);
    R_set_altrep_Length_method(cls, deferred_string_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, deferred_string_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, deferred_string_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, deferred_string_Extract_subset);

    /* override ALTSTRING methods */
    R_set_altstring_Elt_method(cls, deferred_string_Elt);
    R_set_altstring_Set_elt_method(cls, deferred_string_Set_elt);
    R_set_altstring_Is_sorted_method(cls, deferred_string_Is_sorted);
    R_set_altstring_No_NA_method(cls, deferred_string_No_NA);
}


/*
 * Constructor
 */

attribute_hidden SEXP R_deferred_coerceToString(SEXP v, SEXP info)
{
    SEXP ans = R_NilValue;
    switch (TYPEOF(v)) {
    case INTSXP:
    case REALSXP:
  PROTECT(v); /* may not be needed, but to be safe ... */
  if (info == NULL) {
      PrintDefaults(); /* to set R_print from options */
      info = ScalarInteger(R_print.scipen);
      if (strcmp(OutDec, ".")) {
    /* non-default OutDec setting -- attach as an attribute */
    PROTECT(info);
    if (R_OutDecSym == NULL)
        R_OutDecSym = install("OutDec");
    setAttrib(info, R_OutDecSym, GetOption1(R_OutDecSym));
    UNPROTECT(1); /* info */
      }
  }
  MARK_NOT_MUTABLE(v); /* make sure it can't change once captured */
  ans = PROTECT(MAKE_DEFERRED_STRING_STATE(v, info));
  ans = R_new_altrep(R_deferred_string_class, ans, R_NilValue);
  UNPROTECT(2); /* ans, v */
  break;
    default:
  error("unsupported type for deferred string coercion");
    }
    return ans;
}


/**
 ** Memory Mapped Vectors
 **/

/* For now, this code is designed to work both in base R and in a
   package. Some simplifications would be possible if it was only to
   be used in base. in particular, the issue of finalizing objects
   before unloading the library would not need to be addressed, and
   ordinary finalizers in the external pointers could be used instead
   of maintaining a weak reference list of the live mmap objects. */

/*
 * MMAP Object State
 */

/* State is held in a LISTSXP of length 3, and includes
   
       file
       size and length in a REALSXP
       type, ptrOK, wrtOK, serOK in an INTSXP

   These are used by the methods, and also represent the serialized
   state object.
 */

#ifndef Win32
static SEXP make_mmap_state(SEXP file, size_t size, int type,
          Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
{
    SEXP sizes = PROTECT(allocVector(REALSXP, 2));
    double *dsizes = REAL(sizes);
    dsizes[0] = size;
    switch(type) {
    case INTSXP: dsizes[1] = size / sizeof(int); break;
    case REALSXP: dsizes[1] = size / sizeof(double); break;
    default: error("mmap for %s not supported yet", type2char(type));
    }

    SEXP info = PROTECT(allocVector(INTSXP, 4));
    INTEGER(info)[0] = type;
    INTEGER(info)[1] = ptrOK;
    INTEGER(info)[2] = wrtOK;
    INTEGER(info)[3] = serOK;

    SEXP state = list3(file, sizes, info);

    UNPROTECT(2);
    return state;
}
#endif

#define MMAP_STATE_FILE(x) CAR(x)
#define MMAP_STATE_SIZE(x) ((size_t) REAL_ELT(CADR(x), 0))
#define MMAP_STATE_LENGTH(x) ((size_t) REAL_ELT(CADR(x), 1))
#define MMAP_STATE_TYPE(x) INTEGER(CADDR(x))[0]
#define MMAP_STATE_PTROK(x) INTEGER(CADDR(x))[1]
#define MMAP_STATE_WRTOK(x) INTEGER(CADDR(x))[2]
#define MMAP_STATE_SEROK(x) INTEGER(CADDR(x))[3]


/*
 * MMAP Classes and Objects
 */

static R_altrep_class_t mmap_integer_class;
static R_altrep_class_t mmap_real_class;

/* MMAP objects are ALTREP objects with data fields

       data1: an external pointer to the mmaped address
       data2: the MMAP object's state

   The state is also stored in the Protected field of the external
   pointer for use by the finalizer.
*/

#ifndef Win32
static void register_mmap_eptr(SEXP eptr);
static SEXP make_mmap(void *p, SEXP file, size_t size, int type,
          Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
{
    SEXP state = PROTECT(make_mmap_state(file, size,
           type, ptrOK, wrtOK, serOK));
    SEXP eptr = PROTECT(R_MakeExternalPtr(p, R_NilValue, state));
    register_mmap_eptr(eptr);

    R_altrep_class_t class;
    switch(type) {
    case INTSXP:
  class = mmap_integer_class;
  break;
    case REALSXP:
  class = mmap_real_class;
  break;
    default: error("mmap for %s not supported yet", type2char(type));
    }

    SEXP ans = R_new_altrep(class, eptr, state);
    if (ptrOK && ! wrtOK)
  MARK_NOT_MUTABLE(ans);

    UNPROTECT(2); /* state, eptr */
    return ans;
}
#endif

#define MMAP_EPTR(x) R_altrep_data1(x)
#define MMAP_STATE(x) R_altrep_data2(x)
#define MMAP_LENGTH(x) MMAP_STATE_LENGTH(MMAP_STATE(x))
#define MMAP_PTROK(x) MMAP_STATE_PTROK(MMAP_STATE(x))
#define MMAP_WRTOK(x) MMAP_STATE_WRTOK(MMAP_STATE(x))
#define MMAP_SEROK(x) MMAP_STATE_SEROK(MMAP_STATE(x))

#define MMAP_EPTR_STATE(x) R_ExternalPtrProtected(x)

static R_INLINE void *MMAP_ADDR(SEXP x)
{
    SEXP eptr = MMAP_EPTR(x);
    void *addr = R_ExternalPtrAddr(eptr);

    if (addr == NULL)
  error("object has been unmapped");
    return addr;
}

/* We need to maintain a list of weak references to the external
   pointers of memory-mapped objects so a request to unload the shared
   library can finalize them before unloading; otherwise, attempting
   to run a finalizer after unloading would result in an illegal
   instruction. */


#ifndef Win32
static SEXP mmap_list = NULL;

#define MAXCOUNT 10

static void mmap_finalize(SEXP eptr);
static void register_mmap_eptr(SEXP eptr)
{
    if (mmap_list == NULL) {
  mmap_list = CONS(R_NilValue, R_NilValue);
  R_PreserveObject(mmap_list);
    }
    
    /* clean out the weak list every MAXCOUNT calls*/
    static int cleancount = MAXCOUNT;
    if (--cleancount <= 0) {
  cleancount = MAXCOUNT;
  for (SEXP last = mmap_list, next = CDR(mmap_list);
       next != R_NilValue;
       next = CDR(next))
      if (R_WeakRefKey(CAR(next)) == R_NilValue)
    SETCDR(last, CDR(next));
      else
    last = next;
    }

    /* add a weak reference with a finalizer to the list */
    SETCDR(mmap_list, 
     CONS(R_MakeWeakRefC(eptr, R_NilValue, mmap_finalize, TRUE),
    CDR(mmap_list)));

    /* store the weak reference in the external pointer for do_munmap_file */
    R_SetExternalPtrTag(eptr, CAR(CDR(mmap_list)));
}
#endif

#ifdef SIMPLEMMAP
static void finalize_mmap_objects()
{
    if (mmap_list == NULL)
  return;
    
    /* finalize any remaining mmap objects before unloading */
    for (SEXP next = CDR(mmap_list); next != R_NilValue; next = CDR(next))
  R_RunWeakRefFinalizer(CAR(next));
    R_ReleaseObject(mmap_list);
}
#endif


/*
 * ALTREP Methods
 */

static SEXP mmap_Serialized_state(SEXP x)
{
    /* If serOK is FALSE then serialize as a regular typed vector. If
       serOK is true, then serialize information to allow the mmap to
       be reconstructed. The original file name is serialized; it will
       be expanded again when unserializing, in a context where the
       result may be different. */
    if (MMAP_SEROK(x))
  return MMAP_STATE(x);
    else
  return NULL;
}

static SEXP mmap_file(SEXP, int, Rboolean, Rboolean, Rboolean, Rboolean);

static SEXP mmap_Unserialize(SEXP class, SEXP state)
{
    SEXP file = MMAP_STATE_FILE(state);
    int type = MMAP_STATE_TYPE(state);
    Rboolean ptrOK = (Rboolean) MMAP_STATE_PTROK(state);
    Rboolean wrtOK = (Rboolean) MMAP_STATE_WRTOK(state);
    Rboolean serOK = (Rboolean) MMAP_STATE_SEROK(state);

    SEXP val = mmap_file(file, type, ptrOK, wrtOK, serOK, TRUE);
    if (val == NULL) {
  /**** The attempt to memory map failed. Eventually it would be
        good to have a mechanism to allow the user to try to
        resolve this.  For now, return a length zero vector with
        another warning. */
  warning("memory mapping failed; returning vector of length zero");
  return allocVector(type, 0);
    }
    return val;
}

static Rboolean mmap_Inspect(SEXP x, int pre, int deep, int pvec,
           void (*inspect_subtree)(SEXP, int, int, int))
{
    Rboolean ptrOK = (Rboolean) MMAP_PTROK(x);
    Rboolean wrtOK = (Rboolean) MMAP_WRTOK(x);
    Rboolean serOK = (Rboolean) MMAP_SEROK(x);
    Rprintf(" mmaped %s", R_typeToChar(x));
    Rprintf(" [ptr=%d,wrt=%d,ser=%d]\n", ptrOK, wrtOK, serOK);
    return TRUE;
}


/*
 * ALTVEC Methods
 */

static R_xlen_t mmap_Length(SEXP x)
{
    return MMAP_LENGTH(x);
}

static void *mmap_Dataptr(SEXP x, Rboolean writeable)
{
    /* get addr first to get error if the object has been unmapped */
    void *addr = MMAP_ADDR(x);

    if (MMAP_PTROK(x))
  return addr;
    else
  error("cannot access data pointer for this mmaped vector");
}

static const void *mmap_Dataptr_or_null(SEXP x)
{
    return MMAP_PTROK(x) ? MMAP_ADDR(x) : NULL;
}


/*
 * ALTINTEGER Methods
 */

static int mmap_integer_Elt(SEXP x, R_xlen_t i)
{
    int *p = MMAP_ADDR(x);
    return p[i];
}

static
R_xlen_t mmap_integer_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    int *x = MMAP_ADDR(sx);
    R_xlen_t size = XLENGTH(sx);
    R_xlen_t ncopy = size - i > n ? n : size - i;
    for (R_xlen_t k = 0; k < ncopy; k++)
  buf[k] = x[k + i];
    //memcpy(buf, x + i, ncopy * sizeof(int));
    return ncopy;
}


/*
 * ALTREAL Methods
 */

static double mmap_real_Elt(SEXP x, R_xlen_t i)
{
    double *p = MMAP_ADDR(x);
    return p[i];
}

static
R_xlen_t mmap_real_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
{
    double *x = MMAP_ADDR(sx);
    R_xlen_t size = XLENGTH(sx);
    R_xlen_t ncopy = size - i > n ? n : size - i;
    for (R_xlen_t k = 0; k < ncopy; k++)
  buf[k] = x[k + i];
    //memcpy(buf, x + i, ncopy * sizeof(double));
    return ncopy;
}


/*
 * Class Objects and Method Tables
 */

#ifdef SIMPLEMMAP
# define MMAPPKG "simplemmap"
#else
# define MMAPPKG "base"
#endif

static void InitMmapIntegerClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altinteger_class("mmap_integer", MMAPPKG, dll);
    mmap_integer_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, mmap_Unserialize);
    R_set_altrep_Serialized_state_method(cls, mmap_Serialized_state);
    R_set_altrep_Inspect_method(cls, mmap_Inspect);
    R_set_altrep_Length_method(cls, mmap_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, mmap_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, mmap_Dataptr_or_null);

    /* override ALTINTEGER methods */
    R_set_altinteger_Elt_method(cls, mmap_integer_Elt);
    R_set_altinteger_Get_region_method(cls, mmap_integer_Get_region);
}

static void InitMmapRealClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altreal_class("mmap_real", MMAPPKG, dll);
    mmap_real_class = cls;

    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, mmap_Unserialize);
    R_set_altrep_Serialized_state_method(cls, mmap_Serialized_state);
    R_set_altrep_Inspect_method(cls, mmap_Inspect);
    R_set_altrep_Length_method(cls, mmap_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, mmap_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, mmap_Dataptr_or_null);

    /* override ALTREAL methods */
    R_set_altreal_Elt_method(cls, mmap_real_Elt);
    R_set_altreal_Get_region_method(cls, mmap_real_Get_region);
}


/*
 * Constructor
 */

#ifdef Win32
/* unused
static void mmap_finalize(SEXP eptr)
{
    error("mmap objects not supported on Windows yet");
}
*/

static SEXP mmap_file(SEXP file, int type, Rboolean ptrOK, Rboolean wrtOK,
          Rboolean serOK, Rboolean warn)
{
    error("mmap objects not supported on Windows yet");
}
#else
/* derived from the example in
  https://www.safaribooksonline.com/library/view/linux-system-programming/0596009585/ch04s03.html */

#include <sys/stat.h>
#include <fcntl.h>
#include <errno.h>
#include <unistd.h>
#include <sys/mman.h>

//#define DEBUG_PRINT(x) REprintf(x);
#define DEBUG_PRINT(x) do { } while (0)

static void mmap_finalize(SEXP eptr)
{
    DEBUG_PRINT("finalizing ... ");
    void *p = R_ExternalPtrAddr(eptr);
    size_t size = MMAP_STATE_SIZE(MMAP_EPTR_STATE(eptr));

    if (p != NULL) {
  munmap(p, size); /* don't check for errors */
  R_SetExternalPtrAddr(eptr, NULL);
    }
    DEBUG_PRINT("done\n");
}

#define MMAP_FILE_WARNING_OR_ERROR(str, ...) do { \
  if (warn) {         \
      warning(str, __VA_ARGS__);     \
      return NULL;        \
  }           \
  else error(str, __VA_ARGS__);     \
    } while (0)
      
static SEXP mmap_file(SEXP file, int type, Rboolean ptrOK, Rboolean wrtOK,
          Rboolean serOK, Rboolean warn)
{
    const char *efn = R_ExpandFileName(translateCharFP(STRING_ELT(file, 0)));
    struct stat sb;

    /* Target not link */
    if (stat(efn, &sb) != 0)
  MMAP_FILE_WARNING_OR_ERROR("stat: %s", strerror(errno));

    if (! S_ISREG(sb.st_mode))
  MMAP_FILE_WARNING_OR_ERROR("%s is not a regular file", efn);

    int oflags = wrtOK ? O_RDWR : O_RDONLY;
    int fd = open(efn, oflags);
    if (fd == -1)
  MMAP_FILE_WARNING_OR_ERROR("open: %s", strerror(errno));

    int pflags = wrtOK ? PROT_READ | PROT_WRITE : PROT_READ;
    void *p = mmap(0, sb.st_size, pflags, MAP_SHARED, fd, 0);
    close(fd); /* don't care if this fails */
    if (p == MAP_FAILED)
  MMAP_FILE_WARNING_OR_ERROR("mmap: %s", strerror(errno));

    return make_mmap(p, file, sb.st_size, type, ptrOK, wrtOK, serOK);
}
#endif

static Rboolean asLogicalNA(SEXP x, Rboolean dflt)
{
    int val = asLogical(x);
    return val == NA_LOGICAL ? dflt : (Rboolean) val;
}

#ifdef SIMPLEMMAP
SEXP do_mmap_file(SEXP args)
{
    args = CDR(args);
#else
attribute_hidden SEXP do_mmap_file(SEXP call, SEXP op, SEXP args, SEXP env)
{
#endif
    SEXP file = CAR(args);
    SEXP stype = CADR(args);
    SEXP sptrOK = CADDR(args);
    SEXP swrtOK = CADDDR(args);
    SEXP sserOK = CAD4R(args);

    int type = REALSXP;
    if (stype != R_NilValue) {
  const char *typestr = CHAR(asChar(stype));
  if (strcmp(typestr, "double") == 0)
      type = REALSXP;
  else if (strcmp(typestr, "integer") == 0 ||
     strcmp(typestr, "int") == 0)
      type = INTSXP;
  else
      error("type '%s' is not supported", typestr);
    }    

    Rboolean ptrOK = sptrOK == R_NilValue ? TRUE : asLogicalNA(sptrOK, FALSE);
    Rboolean wrtOK = swrtOK == R_NilValue ? FALSE : asLogicalNA(swrtOK, FALSE);
    Rboolean serOK = sserOK == R_NilValue ? FALSE : asLogicalNA(sserOK, FALSE);

    if (TYPEOF(file) != STRSXP || LENGTH(file) != 1 || file == NA_STRING)
  error("invalud 'file' argument");

    return mmap_file(file, type, ptrOK, wrtOK, serOK, FALSE);
}

#ifdef SIMPLEMMAP
static SEXP do_munmap_file(SEXP args)
{
    args = CDR(args);
#else
attribute_hidden SEXP do_munmap_file(SEXP call, SEXP op, SEXP args, SEXP env)
{
#endif
    SEXP x = CAR(args);

    /**** would be useful to have R_mmap_class virtual class as parent here */
    if (! (R_altrep_inherits(x, mmap_integer_class) ||
     R_altrep_inherits(x, mmap_real_class)))
  error("not a memory-mapped object");

    /* using the finalizer is a cheat to avoid yet another #ifdef Windows */
    SEXP eptr = MMAP_EPTR(x);
    errno = 0;
    R_RunWeakRefFinalizer(R_ExternalPtrTag(eptr));
    if (errno)
  error("munmap: %s", strerror(errno));
    return R_NilValue;
}


/**
 ** Attribute and Meta Data Wrappers
 **/

/*
 * Wrapper Classes and Objects
 */

#define NMETA 2

static R_altrep_class_t wrap_integer_class;
static R_altrep_class_t wrap_logical_class;
static R_altrep_class_t wrap_real_class;
static R_altrep_class_t wrap_complex_class;
static R_altrep_class_t wrap_raw_class;
static R_altrep_class_t wrap_string_class;
static R_altrep_class_t wrap_list_class;

/* Wrapper objects are ALTREP objects designed to hold the attributes
   of a potentially large object and/or meta data for the object. */

#define WRAPPER_WRAPPED(x) R_altrep_data1(x)
#define WRAPPER_SET_WRAPPED(x, v) R_set_altrep_data1(x, v)
#define WRAPPER_METADATA(x) R_altrep_data2(x)

#define WRAPPER_SORTED(x) INTEGER(WRAPPER_METADATA(x))[0]
#define WRAPPER_NO_NA(x) INTEGER(WRAPPER_METADATA(x))[1]

/* When a wrapper is created, e.g. using structure(), the data may
   initially be shared. Once it is modified to be modified or a
   DATAPTR is requested the data has to be remain unchanged and the
   wrapper should be the only reference. The metadata is marked to
   reflecth this. The data then has to be duplicated by the duplicate
   method to ensure that no new references are created. This ensures
   that a DATAPTR, once obtained, remains valid while the wrapper
   object is reachable.
   
   For now the sxpinfo.gp field is used via PRSEEN for the lock.
   Allow for cases where shallow_duplicate() returns a value with
   non-zero REFCNT (e.g. returns a value marked not mutable.
 */
#define WRAPPER_DATA_LOCK(x) PRSEEN(WRAPPER_METADATA(x))
#define WRAPPER_SET_DATA_LOCK(x, v) SET_PRSEEN(WRAPPER_METADATA(x), v)
#define WRAPPER_DATA_IS_LOCKED(x) (WRAPPER_DATA_LOCK(x) > 0)
#define WRAPPER_LOCK_DATA(x) WRAPPER_SET_DATA_LOCK(x, 1)
#define WRAPPER_UNLOCK_DATA(x) WRAPPER_SET_DATA_LOCK(x, 0)

 
static R_INLINE SEXP WRAPPER_WRAPPED_RW(SEXP x)
{
    SEXP data = WRAPPER_WRAPPED(x);
    if (WRAPPER_DATA_IS_LOCKED(x)) {
  /* Once data is locked it's reference count should remain at one. */
  /* Unless duplicate() doesn't produce a zero reference count object */ 
  if (MAYBE_SHARED(data) && WRAPPER_DATA_LOCK(x) == 1)
      error("REFCNT on locked WRAPPER data increased to %d",
      REFCNT(data));
    }
    else {
  /* If the data might be shared and is accessed for possible
     modification, then it needs to be duplicated now. */
  if (MAYBE_SHARED(data)) {
      PROTECT(x);
      WRAPPER_SET_WRAPPED(x, shallow_duplicate(data));
      UNPROTECT(1);
      if (REFCNT(WRAPPER_WRAPPED(x)) == 1)
    WRAPPER_LOCK_DATA(x);
      else
    WRAPPER_SET_DATA_LOCK(x, 2);
  }
  else WRAPPER_LOCK_DATA(x);
    }

    /* The meta data also needs to be cleared as it may no longer be
       valid after a write. */
    SEXP meta = WRAPPER_METADATA(x);
    INTEGER(meta)[0] = UNKNOWN_SORTEDNESS;
    for (int i = 1; i < NMETA; i++)
  INTEGER(meta)[i] = 0;

    return WRAPPER_WRAPPED(x);
}


/*
 * ALTREP Methods
 */

static SEXP wrapper_Serialized_state(SEXP x)
{
    /* If the wrapped value is not an ALTREP and there is no useful
       metadata then return NULL to allow this to be serialized as a
       standard object. This avoids serializing potentially large
       attributes on the wrapped value (PR18142). */
    if (! ALTREP(WRAPPER_WRAPPED(x)) &&
  WRAPPER_SORTED(x) == UNKNOWN_SORTEDNESS &&
  ! WRAPPER_NO_NA(x))
  return NULL;

    return CONS(WRAPPER_WRAPPED(x), WRAPPER_METADATA(x));
}

static SEXP make_wrapper(SEXP, SEXP);

static SEXP wrapper_Unserialize(SEXP class, SEXP state)
{
    return make_wrapper(CAR(state), CDR(state));
}

static SEXP wrapper_Duplicate(SEXP x, Rboolean deep)
{
    SEXP data = WRAPPER_WRAPPED(x);

    /* For a deep copy, duplicate the data. */
    /* For a shallow copy, mark as immutable in the NAMED world; with
       reference counting the reference count will be incremented when
       the data is installed in the new wrapper object. */
    if (deep || WRAPPER_DATA_IS_LOCKED(x)) // **** shallow duplicate if only locked?
  data = duplicate(data);
#ifndef SWITCH_TO_REFCNT
    else
  /* not needed with reference counting */
  MARK_NOT_MUTABLE(data);
#endif
    PROTECT(data);

    /* always duplicate the meta data */
    SEXP meta = PROTECT(duplicate(WRAPPER_METADATA(x)));

    SEXP ans = make_wrapper(data, meta);

    UNPROTECT(2); /* data, meta */
    return ans;
}

static Rboolean wrapper_Inspect(SEXP x, int pre, int deep, int pvec,
        void (*inspect_subtree)(SEXP, int, int, int))
{
    Rboolean srt = (Rboolean) WRAPPER_SORTED(x);
    Rboolean no_na = (Rboolean) WRAPPER_NO_NA(x);
    Rboolean lck = (Rboolean) WRAPPER_DATA_IS_LOCKED(x);
    Rprintf(" wrapper [srt=%d,no_na=%d,lck=%d]\n", srt, no_na, lck);
    inspect_subtree(WRAPPER_WRAPPED(x), pre, deep, pvec);
    return TRUE;
}

static R_xlen_t wrapper_Length(SEXP x)
{
    return XLENGTH(WRAPPER_WRAPPED(x));
}


/*
 * ALTVEC Methods
 */

static void *wrapper_Dataptr(SEXP x, Rboolean writeable)
{
    if (writeable)
  return DATAPTR_RW(WRAPPER_WRAPPED_RW(x));
    else
  /* This has to use WRAPPER_WRAPPED_RW even for a read-only
     pointer to make sure a later request for a writable pointer
     will return the same address. */
  /**** could avoid the cast by having separate methods */
  return (void *) DATAPTR_RO(WRAPPER_WRAPPED_RW(x));
}

static const void *wrapper_Dataptr_or_null(SEXP x)
{
    /* This has to use WRAPPER_WRAPPED_RW as above. */
    return DATAPTR_OR_NULL(WRAPPER_WRAPPED_RW(x));
}

static SEXP wrapper_Extract_subset(SEXP x, SEXP indx, SEXP call)
{
  return ExtractSubset(WRAPPER_WRAPPED(x), indx, call);
}


/*
 * ALTINTEGER Methods
 */

static int wrapper_integer_Elt(SEXP x, R_xlen_t i)
{
    return INTEGER_ELT(WRAPPER_WRAPPED(x), i);
}

static
R_xlen_t wrapper_integer_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, int *buf)
{
    return INTEGER_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
}

static int wrapper_integer_Is_sorted(SEXP x)
{
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
  return WRAPPER_SORTED(x);
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return INTEGER_IS_SORTED(WRAPPER_WRAPPED(x));
}

static int wrapper_integer_no_NA(SEXP x)
{
    if (WRAPPER_NO_NA(x))
  return TRUE;
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return INTEGER_NO_NA(WRAPPER_WRAPPED(x));
}


/*
 * ALTLOGICAL Methods
 */

static int wrapper_logical_Elt(SEXP x, R_xlen_t i)
{
    return LOGICAL_ELT(WRAPPER_WRAPPED(x), i);
}

static
R_xlen_t wrapper_logical_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, int *buf)
{
    return LOGICAL_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
}

static int wrapper_logical_Is_sorted(SEXP x)
{
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
  return WRAPPER_SORTED(x);
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return LOGICAL_IS_SORTED(WRAPPER_WRAPPED(x));
}

static int wrapper_logical_no_NA(SEXP x)
{
    if (WRAPPER_NO_NA(x))
  return TRUE;
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return LOGICAL_NO_NA(WRAPPER_WRAPPED(x));
}


/*
 * ALTREAL Methods
 */

static double wrapper_real_Elt(SEXP x, R_xlen_t i)
{
    return REAL_ELT(WRAPPER_WRAPPED(x), i);
}

static
R_xlen_t wrapper_real_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, double *buf)
{
    return REAL_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
}

static int wrapper_real_Is_sorted(SEXP x)
{
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
  return WRAPPER_SORTED(x);
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return REAL_IS_SORTED(WRAPPER_WRAPPED(x));
}

static int wrapper_real_no_NA(SEXP x)
{
    if (WRAPPER_NO_NA(x))
  return TRUE;
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return REAL_NO_NA(WRAPPER_WRAPPED(x));
}


/*
 * ALTCOMPLEX Methods
 */

static Rcomplex wrapper_complex_Elt(SEXP x, R_xlen_t i)
{
    return COMPLEX_ELT(WRAPPER_WRAPPED(x), i);
}

static
R_xlen_t wrapper_complex_Get_region(SEXP x, R_xlen_t i, R_xlen_t n,
            Rcomplex *buf)
{
    return COMPLEX_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
}


/*
 * ALTRAW Methods
 */

static Rbyte wrapper_raw_Elt(SEXP x, R_xlen_t i)
{
    return RAW_ELT(WRAPPER_WRAPPED(x), i);
}

static
R_xlen_t wrapper_raw_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, Rbyte *buf)
{
    return RAW_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
}


/*
 * ALTSTRING Methods
 */

static SEXP wrapper_string_Elt(SEXP x, R_xlen_t i)
{
    return STRING_ELT(WRAPPER_WRAPPED(x), i);
}

static void wrapper_string_Set_elt(SEXP x, R_xlen_t i, SEXP v)
{
    SET_STRING_ELT(WRAPPER_WRAPPED_RW(x), i, v);
}

static int wrapper_string_Is_sorted(SEXP x)
{
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
  return WRAPPER_SORTED(x);
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return STRING_IS_SORTED(WRAPPER_WRAPPED(x));
}

static int wrapper_string_no_NA(SEXP x)
{
    if (WRAPPER_NO_NA(x))
  return TRUE;
    else
  /* If the  meta data bit is not set, defer to the wrapped object. */
  return STRING_NO_NA(WRAPPER_WRAPPED(x));
}


/*
 * ALTLIST Methods
 */

static SEXP wrapper_list_Elt(SEXP x, R_xlen_t i)
{
    return VECTOR_ELT(WRAPPER_WRAPPED(x), i);
}

static void wrapper_list_Set_elt(SEXP x, R_xlen_t i, SEXP v)
{
    SET_VECTOR_ELT(WRAPPER_WRAPPED_RW(x), i, v);
}

/*
 * Class Objects and Method Tables
 */

#define WRAPPKG "base"

static void InitWrapIntegerClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altinteger_class("wrap_integer", WRAPPKG, dll);
    wrap_integer_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTINTEGER methods */
    R_set_altinteger_Elt_method(cls, wrapper_integer_Elt);
    R_set_altinteger_Get_region_method(cls, wrapper_integer_Get_region);
    R_set_altinteger_Is_sorted_method(cls, wrapper_integer_Is_sorted);
    R_set_altinteger_No_NA_method(cls, wrapper_integer_no_NA);
}

static void InitWrapLogicalClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altlogical_class("wrap_logical", WRAPPKG, dll);
    wrap_logical_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTLOGICAL methods */
    R_set_altlogical_Elt_method(cls, wrapper_logical_Elt);
    R_set_altlogical_Get_region_method(cls, wrapper_logical_Get_region);
    R_set_altlogical_Is_sorted_method(cls, wrapper_logical_Is_sorted);
    R_set_altlogical_No_NA_method(cls, wrapper_logical_no_NA);
}

static void InitWrapRealClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altreal_class("wrap_real", WRAPPKG, dll);
    wrap_real_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTREAL methods */
    R_set_altreal_Elt_method(cls, wrapper_real_Elt);
    R_set_altreal_Get_region_method(cls, wrapper_real_Get_region);
    R_set_altreal_Is_sorted_method(cls, wrapper_real_Is_sorted);
    R_set_altreal_No_NA_method(cls, wrapper_real_no_NA);
}

static void InitWrapComplexClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altcomplex_class("wrap_complex", WRAPPKG, dll);
    wrap_complex_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTCOMPLEX methods */
    R_set_altcomplex_Elt_method(cls, wrapper_complex_Elt);
    R_set_altcomplex_Get_region_method(cls, wrapper_complex_Get_region);
}

static void InitWrapRawClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altraw_class("wrap_raw", WRAPPKG, dll);
    wrap_raw_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTRAW methods */
    R_set_altraw_Elt_method(cls, wrapper_raw_Elt);
    R_set_altraw_Get_region_method(cls, wrapper_raw_Get_region);
}

static void InitWrapStringClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altstring_class("wrap_string", WRAPPKG, dll);
    wrap_string_class = cls;
 
    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTSTRING methods */
    R_set_altstring_Elt_method(cls, wrapper_string_Elt);
    R_set_altstring_Set_elt_method(cls, wrapper_string_Set_elt);
    R_set_altstring_Is_sorted_method(cls, wrapper_string_Is_sorted);
    R_set_altstring_No_NA_method(cls, wrapper_string_no_NA);
}

static void InitWrapListClass(DllInfo *dll)
{
    R_altrep_class_t cls =
  R_make_altlist_class("wrap_list", WRAPPKG, dll);
    wrap_list_class = cls;

    /* override ALTREP methods */
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
    R_set_altrep_Length_method(cls, wrapper_Length);

    /* override ALTVEC methods */
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);

    /* override ALTLIST methods */
    R_set_altlist_Elt_method(cls, wrapper_list_Elt);
    R_set_altlist_Set_elt_method(cls, wrapper_list_Set_elt);
}


/*
 * Constructor
 */

static SEXP make_wrapper(SEXP x, SEXP meta)
{
    /* If x is itself a wrapper it might be a good idea to fuse */
    R_altrep_class_t cls;
    switch(TYPEOF(x)) {
    case INTSXP: cls = wrap_integer_class; break;
    case LGLSXP: cls = wrap_logical_class; break;
    case REALSXP: cls = wrap_real_class; break;
    case CPLXSXP: cls = wrap_complex_class; break;
    case RAWSXP: cls = wrap_raw_class; break;
    case STRSXP: cls = wrap_string_class; break;
    case VECSXP: cls = wrap_list_class; break;
    default: error("unsupported type");
    }

    SEXP ans = R_new_altrep(cls, x, meta);

#define WRAPATTRIB
#ifdef WRAPATTRIB
    if (ATTRIB(x) != R_NilValue) {
  /* could just move attributes if there are no references to x */
  PROTECT(ans);
  SET_ATTRIB(ans, shallow_duplicate(ATTRIB(x)));
  SET_OBJECT(ans, OBJECT(x));
  IS_S4_OBJECT(x) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
  UNPROTECT(1); /* ans */
    }
#endif

#ifndef SWITCH_TO_REFCNT
    if (MAYBE_REFERENCED(x))
  /* make sure no mutation can happen through another reference */
  MARK_NOT_MUTABLE(x);
#endif

    WRAPPER_UNLOCK_DATA(ans);
    return ans;
}

static R_INLINE int is_wrapper(SEXP x)
{
    if (ALTREP(x))
  switch(TYPEOF(x)) {
  case INTSXP: return R_altrep_inherits(x, wrap_integer_class);
  case LGLSXP: return R_altrep_inherits(x, wrap_logical_class);
  case REALSXP: return R_altrep_inherits(x, wrap_real_class);
  case CPLXSXP: return R_altrep_inherits(x, wrap_complex_class);
  case RAWSXP: return R_altrep_inherits(x, wrap_raw_class);
  case STRSXP: return R_altrep_inherits(x, wrap_string_class);
  case VECSXP: return R_altrep_inherits(x, wrap_list_class);
  default: return FALSE;
  }
    else return FALSE;
}

static SEXP wrap_meta(SEXP x, int srt, int no_na)
{
    switch(TYPEOF(x)) {
    case INTSXP:
    case REALSXP:
    case LGLSXP:
    case CPLXSXP:
    case RAWSXP:
    case STRSXP:
    case VECSXP: break;
    default: return x;
    }

    /* avoid wrappers of wrappers, at least in some cases */
    if (is_wrapper(x) && srt == UNKNOWN_SORTEDNESS && no_na == FALSE)
  return shallow_duplicate(x);

#ifndef WRAPATTRIB
    if (ATTRIB(x) != R_NilValue)
  /* For objects without references we could move the attributes
     to the wrapper. For objects with references the attributes
     would have to be shallow duplicated at least. The object/S4
     bits would need to be moved as well. */
  /* For now, just return the original object. */
  return x;
#endif

    if (!KNOWN_SORTED(srt) && srt != KNOWN_UNSORTED &&
  srt != UNKNOWN_SORTEDNESS)
  error("srt must be -2, -1, 0, or +1, +2, or NA");
    
    if (no_na < 0 || no_na > 1)
  error("no_na must be 0 or +1");

    SEXP meta = allocVector(INTSXP, NMETA);
    INTEGER(meta)[0] = srt;
    INTEGER(meta)[1] = no_na;

    return make_wrapper(x, meta);
}

attribute_hidden SEXP do_wrap_meta(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP x = CAR(args);
    int srt = asInteger(CADR(args));
    int no_na = asInteger(CADDR(args));
    return wrap_meta(x, srt, no_na);
}

/*attribute_hidden*/ SEXP R_tryWrap(SEXP x)
{
    return wrap_meta(x, UNKNOWN_SORTEDNESS, FALSE);
}

attribute_hidden SEXP do_tryWrap(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP x = CAR(args);
    return R_tryWrap(x);
}

/* When a wrapper has no useful meta-data, is no longer referenced
   anywhere, and its data is only accessible from the wrapper, then
   the wrapper can be unwrapped to its wrapped data, and its
   attributes can be transferred to the data.

   It is ESSENTIAL that the wrapper no longer be accessed after
   this function is called!

   This function can be used at the end of a complex assignment
   operation. It could be used in other places, but extreme caution is
   needed to make sure there is no possibility that the wrapper object
   will be referenced from C code after it is cleared. */
attribute_hidden SEXP R_tryUnwrap(SEXP x)
{
    if (! MAYBE_SHARED(x) && is_wrapper(x) &&
  WRAPPER_SORTED(x) == UNKNOWN_SORTEDNESS && ! WRAPPER_NO_NA(x)) {
  SEXP data = WRAPPER_WRAPPED(x);
  if (! MAYBE_SHARED(data)) {
      SET_ATTRIB(data, ATTRIB(x));
      SET_OBJECT(data, OBJECT(x));
      IS_S4_OBJECT(x) ? SET_S4_OBJECT(data) : UNSET_S4_OBJECT(data);

      /* Clear the fields to drop reference counts and set the
         type to LISTSXP to limit errors in case the object is
         still live. */
      void ALTREP_SET_TYPEOF(SEXP, int); /* in memory.c */
      ALTREP_SET_TYPEOF(x, LISTSXP);
      SETALTREP(x, 0);
      SET_ATTRIB(x, R_NilValue);
      SETCAR(x, R_NilValue);
      SETCDR(x, R_NilValue);
      SET_TAG(x, R_NilValue);
      SET_OBJECT(x, 0);
      UNSET_S4_OBJECT(x);
      /* NAMED should be zero */

      return data;
  }
    }
    return x;
}


/**
 ** Initialize ALTREP Classes
 **/

attribute_hidden void R_init_altrep(void)
{
    InitCompactIntegerClass();
    InitCompactRealClass();
    InitDefferredStringClass();
    InitMmapIntegerClass(NULL);
    InitMmapRealClass(NULL);
    InitWrapIntegerClass(NULL);
    InitWrapLogicalClass(NULL);
    InitWrapRealClass(NULL);
    InitWrapComplexClass(NULL);
    InitWrapRawClass(NULL);
    InitWrapStringClass(NULL);
    InitWrapListClass(NULL);
}

Coverage Report

Created: 2026-10-16 07:07