The R Project SVN R

#define NO_CALL_R

#ifndef NO_CALL_R

// call_R was deprecated in R 2.15.0 and removed from RS.h in R 4.2.0

static const struct {

    const char *name;

    const SEXPTYPE type;

}

typeinfo[] = {

    {"logical",	  LGLSXP },

    {"integer",	  INTSXP },

    {"double",	  REALSXP},

    {"complex",	  CPLXSXP},

    {"character", STRSXP },

    {"list",	  VECSXP },

    {NULL,	  0      }

};

static int string2type(char *s)

{

    int i;

    for (i = 0 ; typeinfo[i].name ; i++) {

	if(!strcmp(typeinfo[i].name, s)) {

	    return typeinfo[i].type;

	}

    }

    error(_("type \"%s\" not supported in interlanguage calls"), s);

    return 1; /* for -Wall */

}

/* This is entirely legacy, with no known users (Mar 2012).

   So we freeze the code involved.

 */

static void *RObjToCPtr2(SEXP s)

{

    int n;

    switch(TYPEOF(s)) {

    case LGLSXP:

    case INTSXP:

	n = LENGTH(s);

	int *iptr = INTEGER(s);

	iptr = (int*) R_alloc(n, sizeof(int));

	for (int i = 0 ; i < n ; i++) iptr[i] = INTEGER(s)[i];

	return (void*) iptr;

	break;

    case REALSXP:

	n = LENGTH(s);

	double *rptr = REAL(s);

	rptr = (double*) R_alloc(n, sizeof(double));

	for (int i = 0 ; i < n ; i++) rptr[i] = REAL(s)[i];

	return (void*) rptr;

	break;

    case CPLXSXP:

	n = LENGTH(s);

	Rcomplex *zptr = COMPLEX(s);

	zptr = (Rcomplex*) R_alloc(n, sizeof(Rcomplex));

	for (int i = 0 ; i < n ; i++) zptr[i] = COMPLEX(s)[i];

	return (void*) zptr;

	break;

    case STRSXP:

	n = LENGTH(s);

	char **cptr = (char**) R_alloc(n, sizeof(char*));

	for (int i = 0 ; i < n ; i++) {

	    const char *ss = translateChar(STRING_ELT(s, i));

	    cptr[i] = (char*) R_alloc(strlen(ss) + 1, sizeof(char));

	    strcpy(cptr[i], ss);

	}

	return (void*) cptr;

	break;

	/* From here down, probably not right */

    case VECSXP:

	n = length(s);

	SEXP *lptr = (SEXP *) R_alloc(n, sizeof(SEXP));

	for (int i = 0 ; i < n ; i++) lptr[i] = VECTOR_ELT(s, i);

	return (void*) lptr;

	break;

    default:

	return (void*) s;

    }

}

void call_R(char *func, long nargs, void **arguments, char **modes,

	    long *lengths, char **names, long nres, char **results)

{

    SEXP call, pcall, s;

    SEXPTYPE type;

    int i, j, n;

    if (!isFunction((SEXP)func))

	error("invalid function in call_R");

    if (nargs < 0)

	error("invalid argument count in call_R");

    if (nres < 0)

	error("invalid return value count in call_R");

    PROTECT(pcall = call = allocList((int) nargs + 1));

    SET_TYPEOF(call, LANGSXP);

    SETCAR(pcall, (SEXP)func);

    s = R_NilValue;		/* -Wall */

    for (i = 0 ; i < nargs ; i++) {

	pcall = CDR(pcall);

	type = string2type(modes[i]);

	switch(type) {

	case LGLSXP:

	case INTSXP:

	    n = (int) lengths[i];

	    SETCAR(pcall, allocVector(type, n));

	    memcpy(INTEGER(CAR(pcall)), arguments[i], n * sizeof(int));

	    break;

	case REALSXP:

	    n = (int) lengths[i];

	    SETCAR(pcall, allocVector(REALSXP, n));

	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(double));

	    break;

	case CPLXSXP:

	    n = (int) lengths[i];

	    SETCAR(pcall, allocVector(CPLXSXP, n));

	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(Rcomplex));

	    break;

	case STRSXP:

	    n = (int) lengths[i];

	    SETCAR(pcall, allocVector(STRSXP, n));

	    for (j = 0 ; j < n ; j++) {

		char *str = (char*)(arguments[i]);

		SET_STRING_ELT(CAR(pcall), i, mkChar(str));

	    }

	    break;

	default:

	    error(_("mode '%s' is not supported in call_R"), modes[i]);

	}

	if(names && names[i])

	    SET_TAG(pcall, install(names[i]));

	ENSURE_NAMEDMAX(CAR(pcall));

    }

    PROTECT(s = eval(call, R_GlobalEnv));

    switch(TYPEOF(s)) {

    case LGLSXP:

    case INTSXP:

    case REALSXP:

    case CPLXSXP:

    case STRSXP:

	if(nres > 0)

	    results[0] = (char *) RObjToCPtr2(s);

	break;

    case VECSXP:

	n = length(s);

	if (nres < n) n = (int) nres;

	for (i = 0 ; i < n ; i++)

	    results[i] = (char *) RObjToCPtr2(VECTOR_ELT(s, i));

	break;

    case LISTSXP:

	n = length(s);

	if(nres < n) n = (int) nres;

	for(i = 0 ; i < n ; i++) {

	    results[i] = (char *) RObjToCPtr2(s);

	    s = CDR(s);

	}

	break;

    }

    UNPROTECT(2);

    return;

}

void call_S(char *func, long nargs, void **arguments, char **modes,

	    long *lengths, char **names, long nres, char **results)

{

    call_R(func, nargs, arguments, modes, lengths, names, nres, results);

}

#endif