The R Project SVN R

Rev

Rev 86615 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed 

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2016--2023   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>


/***
 *** ALTREP Abstract Class Framework 
 ***/

/**
 **  ALTREP Class Registry for Serialization
 **/

/* Use ATTRIB field to hold class info. OK since not visible outside. */
#define ALTREP_CLASS_SERIALIZED_CLASS(x) ATTRIB(x)
#define SET_ALTREP_CLASS_SERIALIZED_CLASS(x, csym, psym, stype) \
    SET_ATTRIB(x, list3(csym, psym, stype))
#define ALTREP_SERIALIZED_CLASS_CLSSYM(x) CAR(x)
#define ALTREP_SERIALIZED_CLASS_PKGSYM(x) CADR(x)
#define ALTREP_SERIALIZED_CLASS_TYPE(x) INTEGER0(CADDR(x))[0]
#define ALTREP_OBJECT_CLSSYM(x) ALTREP_SERIALIZED_CLASS_CLSSYM( \
    ALTREP_SERIALIZED_CLASS(x))
#define ALTREP_OBJECT_PKGSYM(x) ALTREP_SERIALIZED_CLASS_PKGSYM( \
    ALTREP_SERIALIZED_CLASS(x))

#define ALTREP_CLASS_BASE_TYPE(x) \
    ALTREP_SERIALIZED_CLASS_TYPE(ALTREP_CLASS_SERIALIZED_CLASS(x))

static SEXP Registry = NULL;

static SEXP LookupClassEntry(SEXP csym, SEXP psym)
{
    for (SEXP chain = CDR(Registry); chain != R_NilValue; chain = CDR(chain))
    if (TAG(CAR(chain)) == csym && CADR(CAR(chain)) == psym)
        return CAR(chain);
    return NULL;
}

static void
RegisterClass(SEXP class, int type, const char *cname, const char *pname,
          DllInfo *dll)
{
    PROTECT(class);
    if (Registry == NULL) {
    Registry = CONS(R_NilValue, R_NilValue);
    R_PreserveObject(Registry);
    }

    SEXP csym = install(cname);
    SEXP psym = install(pname);
    SEXP stype = PROTECT(ScalarInteger(type));
    SEXP iptr = R_MakeExternalPtr(dll, R_NilValue, R_NilValue);
    SEXP entry = LookupClassEntry(csym, psym);
    if (entry == NULL) {
    entry = list4(class, psym, stype, iptr);
    SET_TAG(entry, csym);
    SETCDR(Registry, CONS(entry, CDR(Registry)));
    }
    else {
    SETCAR(entry, class);
    SETCAR(CDR(CDR(entry)), stype);
    SETCAR(CDR(CDR(CDR(entry))), iptr);
    }
    SET_ALTREP_CLASS_SERIALIZED_CLASS(class, csym, psym, stype);
    UNPROTECT(2); /* class, stype */
}

static SEXP LookupClass(SEXP csym, SEXP psym)
{
    SEXP entry = LookupClassEntry(csym, psym);
    return entry != NULL ? CAR(entry) : NULL;
}

static void reinit_altrep_class(SEXP sclass);
attribute_hidden void R_reinit_altrep_classes(DllInfo *dll)
{
    for (SEXP chain = CDR(Registry); chain != R_NilValue; chain = CDR(chain)) {
    SEXP entry = CAR(chain);
    SEXP iptr = CAR(CDR(CDR(CDR(entry))));
    if (R_ExternalPtrAddr(iptr) == dll)
        reinit_altrep_class(CAR(entry));
    }
}


/**
 **  ALTREP Method Tables and Class Objects
 **/

#define ALTREP_ERROR_IN_CLASS(msg, x) do {          \
    error("%s [class: %s, pkg: %s]",            \
          msg,                      \
          CHAR(PRINTNAME(ALTREP_OBJECT_CLSSYM(x))),     \
          CHAR(PRINTNAME(ALTREP_OBJECT_PKGSYM(x))));    \
    } while(0)

static void SET_ALTREP_CLASS(SEXP x, SEXP class)
{
    SETALTREP(x, 1);
    SET_TAG(x, class);
}

#define CLASS_METHODS_TABLE(class) STDVEC_DATAPTR(class)
#define GENERIC_METHODS_TABLE(x, class) \
    ((class##_methods_t *) CLASS_METHODS_TABLE(ALTREP_CLASS(x)))

#define ALTREP_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altrep)
#define ALTVEC_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altvec)
#define ALTINTEGER_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altinteger)
#define ALTREAL_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altreal)
#define ALTLOGICAL_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altlogical)
#define ALTRAW_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altraw)
#define ALTCOMPLEX_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altcomplex)
#define ALTSTRING_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altstring)
#define ALTLIST_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altlist)

#define ALTREP_METHODS                      \
    R_altrep_UnserializeEX_method_t UnserializeEX;      \
    R_altrep_Unserialize_method_t Unserialize;          \
    R_altrep_Serialized_state_method_t Serialized_state;    \
    R_altrep_DuplicateEX_method_t DuplicateEX;          \
    R_altrep_Duplicate_method_t Duplicate;          \
    R_altrep_Coerce_method_t Coerce;                \
    R_altrep_Inspect_method_t Inspect;              \
    R_altrep_Length_method_t Length

#define ALTVEC_METHODS                  \
    ALTREP_METHODS;                 \
    R_altvec_Dataptr_method_t Dataptr;          \
    R_altvec_Dataptr_or_null_method_t Dataptr_or_null;  \
    R_altvec_Extract_subset_method_t Extract_subset

#define ALTINTEGER_METHODS              \
    ALTVEC_METHODS;                 \
    R_altinteger_Elt_method_t Elt;          \
    R_altinteger_Get_region_method_t Get_region;    \
    R_altinteger_Is_sorted_method_t Is_sorted;      \
    R_altinteger_No_NA_method_t No_NA;          \
    R_altinteger_Sum_method_t Sum ;         \
    R_altinteger_Min_method_t Min;          \
    R_altinteger_Max_method_t Max

#define ALTREAL_METHODS             \
    ALTVEC_METHODS;             \
    R_altreal_Elt_method_t Elt;         \
    R_altreal_Get_region_method_t Get_region;   \
    R_altreal_Is_sorted_method_t Is_sorted; \
    R_altreal_No_NA_method_t No_NA;     \
    R_altreal_Sum_method_t Sum;         \
    R_altreal_Min_method_t Min;         \
    R_altreal_Max_method_t Max

#define ALTLOGICAL_METHODS          \
    ALTVEC_METHODS;             \
    R_altlogical_Elt_method_t Elt;              \
    R_altlogical_Get_region_method_t Get_region;\
    R_altlogical_Is_sorted_method_t Is_sorted;  \
    R_altlogical_No_NA_method_t No_NA;      \
    R_altlogical_Sum_method_t Sum

#define ALTRAW_METHODS              \
    ALTVEC_METHODS;             \
    R_altraw_Elt_method_t Elt;          \
    R_altraw_Get_region_method_t Get_region

#define ALTCOMPLEX_METHODS          \
    ALTVEC_METHODS;             \
    R_altcomplex_Elt_method_t Elt;              \
    R_altcomplex_Get_region_method_t Get_region

#define ALTSTRING_METHODS           \
    ALTVEC_METHODS;             \
    R_altstring_Elt_method_t Elt;       \
    R_altstring_Set_elt_method_t Set_elt;   \
    R_altstring_Is_sorted_method_t Is_sorted;   \
    R_altstring_No_NA_method_t No_NA

#define ALTLIST_METHODS                         \
    ALTVEC_METHODS;                             \
    R_altlist_Elt_method_t Elt;                 \
    R_altlist_Set_elt_method_t Set_elt

typedef struct { ALTREP_METHODS; } altrep_methods_t;
typedef struct { ALTVEC_METHODS; } altvec_methods_t;
typedef struct { ALTINTEGER_METHODS; } altinteger_methods_t;
typedef struct { ALTREAL_METHODS; } altreal_methods_t;
typedef struct { ALTLOGICAL_METHODS; } altlogical_methods_t;
typedef struct { ALTRAW_METHODS; } altraw_methods_t;
typedef struct { ALTCOMPLEX_METHODS; } altcomplex_methods_t;
typedef struct { ALTSTRING_METHODS; } altstring_methods_t;
typedef struct { ALTLIST_METHODS; } altlist_methods_t;

/* Macro to extract first element from ... macro argument.
   From Richard Hansen's answer in
   http://stackoverflow.com/questions/5588855/standard-alternative-to-gccs-va-args-trick 
*/
#define DISPATCH_TARGET(...) DISPATCH_TARGET_HELPER(__VA_ARGS__, dummy)
#define DISPATCH_TARGET_HELPER(x, ...) x

#define DO_DISPATCH(type, fun, ...)                 \
    type##_METHODS_TABLE(DISPATCH_TARGET(__VA_ARGS__))->fun(__VA_ARGS__)

#define ALTREP_DISPATCH(fun, ...) DO_DISPATCH(ALTREP, fun, __VA_ARGS__)
#define ALTVEC_DISPATCH(fun, ...) DO_DISPATCH(ALTVEC, fun, __VA_ARGS__)
#define ALTINTEGER_DISPATCH(fun, ...) DO_DISPATCH(ALTINTEGER, fun, __VA_ARGS__)
#define ALTREAL_DISPATCH(fun, ...) DO_DISPATCH(ALTREAL, fun, __VA_ARGS__)
#define ALTLOGICAL_DISPATCH(fun, ...) DO_DISPATCH(ALTLOGICAL, fun, __VA_ARGS__)
#define ALTRAW_DISPATCH(fun, ...) DO_DISPATCH(ALTRAW, fun, __VA_ARGS__)
#define ALTCOMPLEX_DISPATCH(fun, ...) DO_DISPATCH(ALTCOMPLEX, fun, __VA_ARGS__)
#define ALTSTRING_DISPATCH(fun, ...) DO_DISPATCH(ALTSTRING, fun, __VA_ARGS__)
#define ALTLIST_DISPATCH(fun, ...) DO_DISPATCH(ALTLIST, fun, __VA_ARGS__)


/*
 * Generic ALTREP support
 */

attribute_hidden SEXP ALTREP_COERCE(SEXP x, int type)
{
    return ALTREP_DISPATCH(Coerce, x, type);
}

static SEXP ALTREP_DUPLICATE(SEXP x, Rboolean deep)
{
    return ALTREP_DISPATCH(Duplicate, x, deep);
}

attribute_hidden SEXP ALTREP_DUPLICATE_EX(SEXP x, Rboolean deep)
{
    return ALTREP_DISPATCH(DuplicateEX, x, deep);
}

attribute_hidden Rboolean
ALTREP_INSPECT(SEXP x, int pre, int deep, int pvec,
           void (*inspect_subtree)(SEXP, int, int, int))
{
    return ALTREP_DISPATCH(Inspect, x, pre, deep, pvec, inspect_subtree);
}


attribute_hidden SEXP
ALTREP_SERIALIZED_STATE(SEXP x)
{
    return ALTREP_DISPATCH(Serialized_state, x);
}

attribute_hidden SEXP
ALTREP_SERIALIZED_CLASS(SEXP x)
{
    SEXP val = ALTREP_CLASS_SERIALIZED_CLASS(ALTREP_CLASS(x));
    return val != R_NilValue ? val : NULL;
}

static SEXP find_namespace(void *data) { return R_FindNamespace((SEXP) data); }
static SEXP handle_namespace_error(SEXP cond, void *data) { return R_NilValue; }

static SEXP ALTREP_UNSERIALIZE_CLASS(SEXP info)
{
    if (TYPEOF(info) == LISTSXP) {
    SEXP csym = ALTREP_SERIALIZED_CLASS_CLSSYM(info);
    SEXP psym = ALTREP_SERIALIZED_CLASS_PKGSYM(info);
    SEXP class = LookupClass(csym, psym);
    if (class == NULL) {
        SEXP pname = ScalarString(PRINTNAME(psym));
        PROTECT(pname);
        R_tryCatchError(find_namespace, pname,
                handle_namespace_error, NULL);
        class = LookupClass(csym, psym);
        UNPROTECT(1);
    }
    return class;
    }
    return NULL;
}

attribute_hidden SEXP
ALTREP_UNSERIALIZE_EX(SEXP info, SEXP state, SEXP attr, int objf, int levs)
{
    SEXP csym = ALTREP_SERIALIZED_CLASS_CLSSYM(info);
    SEXP psym = ALTREP_SERIALIZED_CLASS_PKGSYM(info);
    int type = ALTREP_SERIALIZED_CLASS_TYPE(info);

    /* look up the class in the registry and handle failure */
    SEXP class = ALTREP_UNSERIALIZE_CLASS(info);
    if (class == NULL) {
    switch(type) {
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case RAWSXP:
    case VECSXP:
    case EXPRSXP:
        warning("cannot unserialize ALTVEC object of class '%s' from "
            "package '%s'; returning length zero vector",
            CHAR(PRINTNAME(csym)), CHAR(PRINTNAME(psym)));
        return allocVector(type, 0);
    default:
        error("cannot unserialize this ALTREP object");
    }
    }

    /* check the registered and unserialized types match */
    int rtype = ALTREP_CLASS_BASE_TYPE(class);
    if (type != rtype)
    warning("serialized class '%s' from package '%s' has type %s; "
        "registered class has type %s",
        CHAR(PRINTNAME(csym)), CHAR(PRINTNAME(psym)),
        type2char(type), type2char(rtype));
    
    /* dispatch to a class method */
    altrep_methods_t *m = CLASS_METHODS_TABLE(class);
    SEXP val = m->UnserializeEX(class, state, attr, objf, levs);
    return val;
}

/*attribute_hidden*/ R_xlen_t ALTREP_LENGTH(SEXP x)
{
    return ALTREP_DISPATCH(Length, x);
}

attribute_hidden R_xlen_t ALTREP_TRUELENGTH(SEXP x) { return 0; }


/*
 * Generic ALTVEC support
 */

static R_INLINE void *ALTVEC_DATAPTR_EX(SEXP x, Rboolean writable)
{
    /* Disallow taking the writable `DATAPTR()` of an ALTLIST. This
       check could be moved to `DATAPTR()` to catch more faulty
       usages. */
    if (TYPEOF(x) == VECSXP && writable)
        ALTREP_ERROR_IN_CLASS("cannot take a writable DATAPTR of an ALTLIST",
                  x);

    /**** move GC disabling into methods? */
    if (R_in_gc)
    error("cannot get ALTVEC DATAPTR during GC");
    R_CHECK_THREAD;
    int enabled = R_GCEnabled;
    R_GCEnabled = FALSE;

    void *val = ALTVEC_DISPATCH(Dataptr, x, writable);

    R_GCEnabled = enabled;
    return val;
}

/*attribute_hidden*/ void *ALTVEC_DATAPTR(SEXP x)
{
    return ALTVEC_DATAPTR_EX(x, TRUE);
}

/*attribute_hidden*/ const void *ALTVEC_DATAPTR_RO(SEXP x)
{
    return ALTVEC_DATAPTR_EX(x, FALSE);
}

attribute_hidden const void *ALTVEC_DATAPTR_OR_NULL(SEXP x)
{
    return ALTVEC_DISPATCH(Dataptr_or_null, x);
}

attribute_hidden SEXP ALTVEC_EXTRACT_SUBSET(SEXP x, SEXP indx, SEXP call)
{
    return ALTVEC_DISPATCH(Extract_subset, x, indx, call);
}


/*
 * Typed ALTVEC support
 */

attribute_hidden int ALTINTEGER_ELT(SEXP x, R_xlen_t i)
{
    return ALTINTEGER_DISPATCH(Elt, x, i);
}

R_xlen_t INTEGER_GET_REGION(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    const int *x = INTEGER_OR_NULL(sx);
    if (x != NULL) {
    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;
    }
    else
    return ALTINTEGER_DISPATCH(Get_region, sx, i, n, buf);
}

int INTEGER_IS_SORTED(SEXP x)
{
    return ALTREP(x) ? ALTINTEGER_DISPATCH(Is_sorted, x) : UNKNOWN_SORTEDNESS;
}

int INTEGER_NO_NA(SEXP x)
{
    return ALTREP(x) ? ALTINTEGER_DISPATCH(No_NA, x) : 0;
}

attribute_hidden double ALTREAL_ELT(SEXP x, R_xlen_t i)
{
    return ALTREAL_DISPATCH(Elt, x, i);
}

R_xlen_t REAL_GET_REGION(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
{
    const double *x = REAL_OR_NULL(sx);
    if (x != NULL) {
    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;
    }
    else
    return ALTREAL_DISPATCH(Get_region, sx, i, n, buf);
}

int REAL_IS_SORTED(SEXP x)
{
    return ALTREP(x) ? ALTREAL_DISPATCH(Is_sorted, x) : UNKNOWN_SORTEDNESS;
}

int REAL_NO_NA(SEXP x)
{
    return ALTREP(x) ? ALTREAL_DISPATCH(No_NA, x) : 0;
}

R_xlen_t LOGICAL_GET_REGION(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    const int *x = DATAPTR_OR_NULL(sx);
    if (x != NULL) {
    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;
    }
    else
    return ALTLOGICAL_DISPATCH(Get_region, sx, i, n, buf);
}

attribute_hidden int LOGICAL_IS_SORTED(SEXP x)
{
    return ALTREP(x) ? ALTLOGICAL_DISPATCH(Is_sorted, x) : UNKNOWN_SORTEDNESS;
}


int LOGICAL_NO_NA(SEXP x)
{
    return ALTREP(x) ? ALTLOGICAL_DISPATCH(No_NA, x) : 0;
}


R_xlen_t RAW_GET_REGION(SEXP sx, R_xlen_t i, R_xlen_t n, Rbyte *buf)
{
    const Rbyte *x = DATAPTR_OR_NULL(sx);
    if (x != NULL) {
    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;
    }
    else
    return ALTRAW_DISPATCH(Get_region, sx, i, n, buf);
}


R_xlen_t COMPLEX_GET_REGION(SEXP sx, R_xlen_t i, R_xlen_t n, Rcomplex *buf)
{
    const Rcomplex *x = DATAPTR_OR_NULL(sx);
    if (x != NULL) {
    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;
    }
    else
    return ALTCOMPLEX_DISPATCH(Get_region, sx, i, n, buf);
}


SEXP /*attribute_hidden*/ ALTSTRING_ELT(SEXP x, R_xlen_t i)
{
    SEXP val = NULL;

    /**** move GC disabling into method? */
    if (R_in_gc)
    error("cannot get ALTSTRING_ELT during GC");
    R_CHECK_THREAD;
    int enabled = R_GCEnabled;
    R_GCEnabled = FALSE;

    val = ALTSTRING_DISPATCH(Elt, x, i);

    R_GCEnabled = enabled;
    return val;
}

attribute_hidden void ALTSTRING_SET_ELT(SEXP x, R_xlen_t i, SEXP v)
{
    /**** move GC disabling into method? */
    if (R_in_gc)
    error("cannot set ALTSTRING_ELT during GC");
    R_CHECK_THREAD;
    int enabled = R_GCEnabled;
    R_GCEnabled = FALSE;

    ALTSTRING_DISPATCH(Set_elt, x, i, v);

    R_GCEnabled = enabled;
}

int STRING_IS_SORTED(SEXP x)
{
    return ALTREP(x) ? ALTSTRING_DISPATCH(Is_sorted, x) : UNKNOWN_SORTEDNESS;
}

int STRING_NO_NA(SEXP x)
{
    return ALTREP(x) ? ALTSTRING_DISPATCH(No_NA, x) : 0;
}

attribute_hidden SEXP ALTLIST_ELT(SEXP x, R_xlen_t i)
{
    SEXP val = NULL;

    /**** move GC disabling into method? */
    if (R_in_gc)
    error("cannot get ALTLIST_ELT during GC");
    R_CHECK_THREAD;
    int enabled = R_GCEnabled;
    R_GCEnabled = FALSE;

    val = ALTLIST_DISPATCH(Elt, x, i);

    R_GCEnabled = enabled;
    return val;
}

attribute_hidden void ALTLIST_SET_ELT(SEXP x, R_xlen_t i, SEXP v)
{
    /**** move GC disabling into method? */
    if (R_in_gc)
    error("cannot set ALTLIST_ELT during GC");
    R_CHECK_THREAD;
    int enabled = R_GCEnabled;
    R_GCEnabled = FALSE;

    ALTLIST_DISPATCH(Set_elt, x, i, v);

    R_GCEnabled = enabled;
}

attribute_hidden SEXP ALTINTEGER_SUM(SEXP x, Rboolean narm)
{
    return ALTINTEGER_DISPATCH(Sum, x, narm);
}

attribute_hidden SEXP ALTINTEGER_MIN(SEXP x, Rboolean narm)
{
    return ALTINTEGER_DISPATCH(Min, x, narm);
}

attribute_hidden SEXP ALTINTEGER_MAX(SEXP x, Rboolean narm)
{
    return ALTINTEGER_DISPATCH(Max, x, narm);

}

attribute_hidden SEXP ALTREAL_SUM(SEXP x, Rboolean narm)
{
    return ALTREAL_DISPATCH(Sum, x, narm);
}

attribute_hidden SEXP ALTREAL_MIN(SEXP x, Rboolean narm)
{
    return ALTREAL_DISPATCH(Min, x, narm);
}

attribute_hidden SEXP ALTREAL_MAX(SEXP x, Rboolean narm)
{
    return ALTREAL_DISPATCH(Max, x, narm);

}

attribute_hidden SEXP ALTLOGICAL_SUM(SEXP x, Rboolean narm)
{
    return ALTLOGICAL_DISPATCH(Sum, x, narm);
}

attribute_hidden int ALTLOGICAL_ELT(SEXP x, R_xlen_t i)
{
    return ALTLOGICAL_DISPATCH(Elt, x, i);
}

attribute_hidden Rcomplex ALTCOMPLEX_ELT(SEXP x, R_xlen_t i)
{
    return ALTCOMPLEX_DISPATCH(Elt, x, i);
}

attribute_hidden Rbyte ALTRAW_ELT(SEXP x, R_xlen_t i)
{
    return ALTRAW_DISPATCH(Elt, x, i);
}


/*
 * Not yet implemented
 */

attribute_hidden void ALTINTEGER_SET_ELT(SEXP x, R_xlen_t i, int v)
{
    INTEGER(x)[i] = v; /* dispatch here */
}

attribute_hidden void ALTLOGICAL_SET_ELT(SEXP x, R_xlen_t i, int v)
{
    LOGICAL(x)[i] = v; /* dispatch here */
}

attribute_hidden void ALTREAL_SET_ELT(SEXP x, R_xlen_t i, double v)
{
    REAL(x)[i] = v; /* dispatch here */
}

attribute_hidden void ALTCOMPLEX_SET_ELT(SEXP x, R_xlen_t i, Rcomplex v)
{
    COMPLEX(x)[i] = v; /* dispatch here */
}

attribute_hidden void ALTRAW_SET_ELT(SEXP x, R_xlen_t i, Rbyte v)
{
    RAW(x)[i] = v; /* dispatch here */
}


/**
 ** ALTREP Default Methods
 **/

static SEXP altrep_UnserializeEX_default(SEXP class, SEXP state, SEXP attr,
                     int objf, int levs)
{
    altrep_methods_t *m = CLASS_METHODS_TABLE(class);
    SEXP val = m->Unserialize(class, state);
    SET_ATTRIB(val, attr);
    SET_OBJECT(val, objf);
    SETLEVELS(val, levs);
    return val;
}

static SEXP altrep_Serialized_state_default(SEXP x) { return NULL; }

static SEXP altrep_Unserialize_default(SEXP class, SEXP state)
{
    error("cannot unserialize this ALTREP object yet");
}

static SEXP altrep_Coerce_default(SEXP x, int type) { return NULL; }

static SEXP altrep_Duplicate_default(SEXP x, Rboolean deep)
{
    return NULL;
}

static SEXP altrep_DuplicateEX_default(SEXP x, Rboolean deep)
{
    SEXP ans = ALTREP_DUPLICATE(x, deep);

    if (ans != NULL &&
    ans != x) { /* leave attributes alone if returning original */
    /* handle attributes generically */
    SEXP attr = ATTRIB(x);
    if (attr != R_NilValue) {
        PROTECT(ans);
        SET_ATTRIB(ans, deep ? duplicate(attr) : shallow_duplicate(attr));
        SET_OBJECT(ans, OBJECT(x));
        IS_S4_OBJECT(x) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
        UNPROTECT(1);
    }
    else if (ATTRIB(ans) != R_NilValue) {
        SET_ATTRIB(ans, R_NilValue);
        SET_OBJECT(ans, FALSE);
        UNSET_S4_OBJECT(ans);
    }
    }
    return ans;
}

static
Rboolean altrep_Inspect_default(SEXP x, int pre, int deep, int pvec,
                void (*inspect_subtree)(SEXP, int, int, int))
{
    return FALSE;
}

static R_xlen_t altrep_Length_default(SEXP x)
{
    ALTREP_ERROR_IN_CLASS("no ALTREP Length method defined", x);
}

static void *altvec_Dataptr_default(SEXP x, Rboolean writable)
{
    ALTREP_ERROR_IN_CLASS("cannot access data pointer for this ALTVEC object", x);
}

static const void *altvec_Dataptr_or_null_default(SEXP x)
{
    return NULL;
}

static SEXP altvec_Extract_subset_default(SEXP x, SEXP indx, SEXP call)
{
    return NULL;
}

static int altinteger_Elt_default(SEXP x, R_xlen_t i) { return INTEGER(x)[i]; }

static R_xlen_t
altinteger_Get_region_default(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    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] = INTEGER_ELT(sx, k + i);
    return ncopy;
}

static int altinteger_Is_sorted_default(SEXP x) { return UNKNOWN_SORTEDNESS; }
static int altinteger_No_NA_default(SEXP x) { return 0; }

static SEXP altinteger_Sum_default(SEXP x, Rboolean narm) { return NULL; }
static SEXP altinteger_Min_default(SEXP x, Rboolean narm) { return NULL; }
static SEXP altinteger_Max_default(SEXP x, Rboolean narm) { return NULL; }

static double altreal_Elt_default(SEXP x, R_xlen_t i) { return REAL(x)[i]; }

static R_xlen_t
altreal_Get_region_default(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
{
    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] = REAL_ELT(sx, k + i);
    return ncopy;
}

static int altreal_Is_sorted_default(SEXP x) { return UNKNOWN_SORTEDNESS; }
static int altreal_No_NA_default(SEXP x) { return 0; }

static SEXP altreal_Sum_default(SEXP x, Rboolean narm) { return NULL; }
static SEXP altreal_Min_default(SEXP x, Rboolean narm) { return NULL; }
static SEXP altreal_Max_default(SEXP x, Rboolean narm) { return NULL; }

static int altlogical_Elt_default(SEXP x, R_xlen_t i) { return LOGICAL(x)[i]; }

static R_xlen_t
altlogical_Get_region_default(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
    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] = LOGICAL_ELT(sx, k + i);
    return ncopy;
}

static int altlogical_Is_sorted_default(SEXP x) { return UNKNOWN_SORTEDNESS; }
static int altlogical_No_NA_default(SEXP x) { return 0; }

static SEXP altlogical_Sum_default(SEXP x, Rboolean narm) { return NULL; }


static Rbyte altraw_Elt_default(SEXP x, R_xlen_t i) { return RAW(x)[i]; }

static R_xlen_t
altraw_Get_region_default(SEXP sx, R_xlen_t i, R_xlen_t n, Rbyte *buf)
{
    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] = RAW_ELT(sx, k + i);
    return ncopy;
}


static Rcomplex altcomplex_Elt_default(SEXP x, R_xlen_t i)
{
    return COMPLEX(x)[i];
}

static R_xlen_t
altcomplex_Get_region_default(SEXP sx, R_xlen_t i, R_xlen_t n, Rcomplex *buf)
{
    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] = COMPLEX_ELT(sx, k + i);
    return ncopy;
}

static SEXP altstring_Elt_default(SEXP x, R_xlen_t i)
{
    ALTREP_ERROR_IN_CLASS("No Elt method found for ALTSTRING class", x);
}

static void altstring_Set_elt_default(SEXP x, R_xlen_t i, SEXP v)
{
    ALTREP_ERROR_IN_CLASS("No Set_elt found for ALTSTRING class", x);
}

static int altstring_Is_sorted_default(SEXP x) { return UNKNOWN_SORTEDNESS; }
static int altstring_No_NA_default(SEXP x) { return 0; }

static SEXP altlist_Elt_default(SEXP x, R_xlen_t i)
{
    ALTREP_ERROR_IN_CLASS("ALTLIST classes must provide an Elt method", x);
}

static void altlist_Set_elt_default(SEXP x, R_xlen_t i, SEXP v)
{
    ALTREP_ERROR_IN_CLASS("ALTLIST classes must provide a Set_elt method", x);
}

static void *altlist_Dataptr_default(SEXP x, Rboolean writable)
{
    ALTREP_ERROR_IN_CLASS("No Dataptr method found for ALTLIST class", x);
}

static const void *altlist_Dataptr_or_null_default(SEXP x)
{
    return NULL;
}

/**
 ** ALTREP Initial Method Tables
 **/

static altinteger_methods_t altinteger_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altinteger_Elt_default,
    .Get_region = altinteger_Get_region_default,
    .Is_sorted = altinteger_Is_sorted_default,
    .No_NA = altinteger_No_NA_default,
    .Sum = altinteger_Sum_default,
    .Min = altinteger_Min_default,
    .Max = altinteger_Max_default
};

static altreal_methods_t altreal_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altreal_Elt_default,
    .Get_region = altreal_Get_region_default,
    .Is_sorted = altreal_Is_sorted_default,
    .No_NA = altreal_No_NA_default,
    .Sum = altreal_Sum_default,
    .Min = altreal_Min_default,
    .Max = altreal_Max_default
};


static altlogical_methods_t altlogical_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altlogical_Elt_default,
    .Get_region = altlogical_Get_region_default,
    .Is_sorted = altlogical_Is_sorted_default,
    .No_NA = altlogical_No_NA_default,
    .Sum = altlogical_Sum_default
};


static altraw_methods_t altraw_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altraw_Elt_default,
    .Get_region = altraw_Get_region_default
};




static altcomplex_methods_t altcomplex_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altcomplex_Elt_default,
    .Get_region = altcomplex_Get_region_default
};



static altstring_methods_t altstring_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altvec_Dataptr_default,
    .Dataptr_or_null = altvec_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altstring_Elt_default,
    .Set_elt = altstring_Set_elt_default,
    .Is_sorted = altstring_Is_sorted_default,
    .No_NA = altstring_No_NA_default
};



static altlist_methods_t altlist_default_methods = {
    .UnserializeEX = altrep_UnserializeEX_default,
    .Unserialize = altrep_Unserialize_default,
    .Serialized_state = altrep_Serialized_state_default,
    .DuplicateEX = altrep_DuplicateEX_default,
    .Duplicate = altrep_Duplicate_default,
    .Coerce = altrep_Coerce_default,
    .Inspect = altrep_Inspect_default,
    .Length = altrep_Length_default,
    .Dataptr = altlist_Dataptr_default,
    .Dataptr_or_null = altlist_Dataptr_or_null_default,
    .Extract_subset = altvec_Extract_subset_default,
    .Elt = altlist_Elt_default,
    .Set_elt = altlist_Set_elt_default
};


/**
 ** Class Constructors
 **/

#define INIT_CLASS(cls, type) do {              \
    *((type##_methods_t *) (CLASS_METHODS_TABLE(cls))) =    \
        type##_default_methods;             \
    } while (FALSE)

#define MAKE_CLASS(var, type) do {              \
    var = allocVector(RAWSXP, sizeof(type##_methods_t));    \
    R_PreserveObject(var);                  \
    INIT_CLASS(var, type);                  \
    } while (FALSE)

static R_INLINE R_altrep_class_t R_cast_altrep_class(SEXP x)
{
    /**** some king of optional check? */
    R_altrep_class_t val = R_SUBTYPE_INIT(x);
    return val;
}

static R_altrep_class_t
make_altrep_class(int type, const char *cname, const char *pname, DllInfo *dll)
{
    SEXP class;
    switch(type) {
    case INTSXP:  MAKE_CLASS(class, altinteger); break;
    case REALSXP: MAKE_CLASS(class, altreal);    break;
    case LGLSXP:  MAKE_CLASS(class, altlogical); break;
    case RAWSXP:  MAKE_CLASS(class, altraw);     break;
    case CPLXSXP: MAKE_CLASS(class, altcomplex); break;
    case STRSXP:  MAKE_CLASS(class, altstring);  break;
    case VECSXP:  MAKE_CLASS(class, altlist);    break;
    default: error("unsupported ALTREP class");
    }
    RegisterClass(class, type, cname, pname, dll);
    return R_cast_altrep_class(class);
}

/*  Using macros like this makes it easier to add new methods, but
    makes searching for source harder. Probably a good idea on
    balance though. */
#define DEFINE_CLASS_CONSTRUCTOR(cls, type)         \
    R_altrep_class_t R_make_##cls##_class(const char *cname,    \
                      const char *pname,    \
                      DllInfo *dll)     \
    {                               \
    return  make_altrep_class(type, cname, pname, dll); \
    }

DEFINE_CLASS_CONSTRUCTOR(altstring, STRSXP)
DEFINE_CLASS_CONSTRUCTOR(altlist, VECSXP)
DEFINE_CLASS_CONSTRUCTOR(altinteger, INTSXP)
DEFINE_CLASS_CONSTRUCTOR(altreal, REALSXP)
DEFINE_CLASS_CONSTRUCTOR(altlogical, LGLSXP)
DEFINE_CLASS_CONSTRUCTOR(altraw, RAWSXP)
DEFINE_CLASS_CONSTRUCTOR(altcomplex, CPLXSXP)

static void reinit_altrep_class(SEXP class)
{
    switch (ALTREP_CLASS_BASE_TYPE(class)) {
    case INTSXP: INIT_CLASS(class, altinteger); break;
    case REALSXP: INIT_CLASS(class, altreal); break;
    case STRSXP: INIT_CLASS(class, altstring); break;
    case LGLSXP: INIT_CLASS(class, altlogical); break;
    case RAWSXP: INIT_CLASS(class, altraw); break;
    case CPLXSXP: INIT_CLASS(class, altcomplex); break;
    case VECSXP: INIT_CLASS(class, altlist); break;
    default: error("unsupported ALTREP class");
    }
}


/**
 ** ALTREP Method Setters
 **/

#define DEFINE_METHOD_SETTER(CNAME, MNAME)              \
    void R_set_##CNAME##_##MNAME##_method(R_altrep_class_t cls,     \
                      R_##CNAME##_##MNAME##_method_t fun) \
    {                                   \
    CNAME##_methods_t *m = CLASS_METHODS_TABLE(R_SEXP(cls));    \
    m->MNAME = fun;                         \
    }

DEFINE_METHOD_SETTER(altrep, UnserializeEX)
DEFINE_METHOD_SETTER(altrep, Unserialize)
DEFINE_METHOD_SETTER(altrep, Serialized_state)
DEFINE_METHOD_SETTER(altrep, DuplicateEX)
DEFINE_METHOD_SETTER(altrep, Duplicate)
DEFINE_METHOD_SETTER(altrep, Coerce)
DEFINE_METHOD_SETTER(altrep, Inspect)
DEFINE_METHOD_SETTER(altrep, Length)

DEFINE_METHOD_SETTER(altvec, Dataptr)
DEFINE_METHOD_SETTER(altvec, Dataptr_or_null)
DEFINE_METHOD_SETTER(altvec, Extract_subset)

DEFINE_METHOD_SETTER(altinteger, Elt)
DEFINE_METHOD_SETTER(altinteger, Get_region)
DEFINE_METHOD_SETTER(altinteger, Is_sorted)
DEFINE_METHOD_SETTER(altinteger, No_NA)
DEFINE_METHOD_SETTER(altinteger, Sum)
DEFINE_METHOD_SETTER(altinteger, Min)
DEFINE_METHOD_SETTER(altinteger, Max)

DEFINE_METHOD_SETTER(altreal, Elt)
DEFINE_METHOD_SETTER(altreal, Get_region)
DEFINE_METHOD_SETTER(altreal, Is_sorted)
DEFINE_METHOD_SETTER(altreal, No_NA)
DEFINE_METHOD_SETTER(altreal, Sum)
DEFINE_METHOD_SETTER(altreal, Min)
DEFINE_METHOD_SETTER(altreal, Max)

DEFINE_METHOD_SETTER(altlogical, Elt)
DEFINE_METHOD_SETTER(altlogical, Get_region)
DEFINE_METHOD_SETTER(altlogical, Is_sorted)
DEFINE_METHOD_SETTER(altlogical, No_NA)
DEFINE_METHOD_SETTER(altlogical, Sum)

DEFINE_METHOD_SETTER(altraw, Elt)
DEFINE_METHOD_SETTER(altraw, Get_region)

DEFINE_METHOD_SETTER(altcomplex, Elt)
DEFINE_METHOD_SETTER(altcomplex, Get_region)

DEFINE_METHOD_SETTER(altstring, Elt)
DEFINE_METHOD_SETTER(altstring, Set_elt)
DEFINE_METHOD_SETTER(altstring, Is_sorted)
DEFINE_METHOD_SETTER(altstring, No_NA)

DEFINE_METHOD_SETTER(altlist, Elt)
DEFINE_METHOD_SETTER(altlist, Set_elt)

/**
 ** ALTREP Object Constructor and Utility Functions
 **/

SEXP R_new_altrep(R_altrep_class_t aclass, SEXP data1, SEXP data2)
{
    void ALTREP_SET_TYPEOF(SEXP, int); /* in memory.c */
    SEXP sclass = R_SEXP(aclass);
    int type = ALTREP_CLASS_BASE_TYPE(sclass);
    SEXP ans = CONS(data1, data2);
    ALTREP_SET_TYPEOF(ans, type);
    SET_ALTREP_CLASS(ans, sclass);
    return ans;
}

Rboolean R_altrep_inherits(SEXP x, R_altrep_class_t class)
{
    return ALTREP(x) && ALTREP_CLASS(x) == R_SEXP(class);
}

SEXP R_altrep_class_name(SEXP x)
{
    return ALTREP(x) ? CAR(ATTRIB(ALTREP_CLASS(x))) : R_NilValue;
}

SEXP R_altrep_class_package(SEXP x)
{
    return ALTREP(x) ? CADR(ATTRIB(ALTREP_CLASS(x))) : R_NilValue;
}

attribute_hidden SEXP do_altrep_class(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP x = CAR(args);
    if (ALTREP(x)) {
    SEXP info = ALTREP_SERIALIZED_CLASS(x);
    SEXP val = allocVector(STRSXP, 2);
    SET_STRING_ELT(val, 0, PRINTNAME(ALTREP_SERIALIZED_CLASS_CLSSYM(info)));
    SET_STRING_ELT(val, 1, PRINTNAME(ALTREP_SERIALIZED_CLASS_PKGSYM(info)));
    return val;
    }
    else
    return R_NilValue;
}