diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
fddb79895d
yap-6.3/packages/real/real.c
Vitor Santos Costa 65ff3ed471 Smaller updates: 
constant use of longjmp
conflict with python headers
win32 support
dll support
2017-02-20 15:28:46 +00:00

2211 lines
58 KiB
C
Raw Blame History

#define CSTACK_DEFNS
#include "rconfig.h"
#if HAVE_R_H || !defined(_YAP_NOT_INSTALLED_)
#include <SWI-Prolog.h>
#if HAVE_R_EMBEDDED_H
#include <Rembedded.h>
#endif
#include <R.h>
#include <Rinternals.h>
#if HAVE_R_INTERFACE_H
#include <Rinterface.h>
#define R_SIGNAL_HANDLERS 1
#endif
#include <R_ext/Parse.h>
#include <Rdefines.h>
#include <assert.h>
#include <string.h>
bool R_isNull(SEXP sexp);
#if DEBUG_MEMORY
#define PROTECT_AND_COUNT(EXP) \
{ \
extern int R_PPStackTop; \
PROTECT(EXP); \
nprotect++; \
printf("%s:%d +%d=%d\n", __FUNCTION__, __LINE__, nprotect, R_PPStackTop); \
}
#define Ureturn \
{ \
extern int R_PPStackTop; \
printf("%s:%d -%d=%d\n", __FUNCTION__, __LINE__, nprotect, \
R_PPStackTop - nprotect); \
} \
unprotect(nprotect); \
return
#else
#define PROTECT_AND_COUNT(EXP) \
{ \
PROTECT(EXP); \
nprotect++; \
}
#define Ureturn \
unprotect(nprotect); \
return
#endif
// #define PL_free(v)
static inline SEXP protected_tryEval(SEXP expr, SEXP env, int *errp) {
SEXP o;
o = R_tryEval(expr, env, errp);
return o ? o : expr;
}
static atom_t ATOM_break;
static atom_t ATOM_false;
static atom_t ATOM_function;
static atom_t ATOM_i;
static atom_t ATOM_next;
static atom_t ATOM_true;
static functor_t FUNCTOR_at2;
static functor_t FUNCTOR_boolop1;
static functor_t FUNCTOR_brackets1;
static functor_t FUNCTOR_dollar1;
static functor_t FUNCTOR_dollar2;
static functor_t FUNCTOR_dot1;
static functor_t FUNCTOR_equal2;
static functor_t FUNCTOR_hat2;
static functor_t FUNCTOR_i1;
static functor_t FUNCTOR_if2;
static functor_t FUNCTOR_iff2;
static functor_t FUNCTOR_iff3;
static functor_t FUNCTOR_in2;
static functor_t FUNCTOR_inner2;
static functor_t FUNCTOR_for3;
static functor_t FUNCTOR_minus1;
static functor_t FUNCTOR_minus2;
static functor_t FUNCTOR_outer2;
static functor_t FUNCTOR_plus1;
static functor_t FUNCTOR_plus2;
static functor_t FUNCTOR_quote1;
static functor_t FUNCTOR_repeat1;
static functor_t FUNCTOR_square_brackets2;
static functor_t FUNCTOR_tilde1;
static functor_t FUNCTOR_tilde2;
static functor_t FUNCTOR_while2;
X_API install_t install_real(void);
static SEXP term_to_sexp(term_t t, bool eval);
static int sexp_to_pl(term_t t, SEXP s);
#define PL_R_BOOL (1) /* const char * */
#define PL_R_CHARS (2) /* const char * */
#define PL_R_INTEGER (3) /* int */
#define PL_R_FLOAT (4) /* double */
#define PL_R_COMPLEX (5) /* x + yi * */
#define PL_R_SYMBOL (6) /* A * */
#define PL_R_CALL (7) /* A(F) * */
#define PL_R_LISTEL (8) /* X$listEl * */
#define PL_R_SLOT (9) /* X@slot * */
#define PL_R_NAME (10) /* name = X, just within a list * */
#define PL_R_PLUS (11) /* +X * */
#define PL_R_PSYMBOL (12) /* -X * */
#define PL_R_ATBOOL (13) /* @X * */
#define PL_R_VARIABLE (14) /* _ */
#define PL_R_SUBSET (15) /* [] */
#define PL_R_DOT (16) /* . */
#define PL_R_DEFUN (17) /* function(_,_,_) -> ... */
#define PL_R_QUOTE (18) /* quote(_) */
#define PL_R_INNER (19) /* %i% */
#define PL_R_OUTER (20) /* %o% */
#define PL_R_FORMULA (21) /* At ~ Exp */
#define PL_R_IF (22) /* if(Cond, Then) */
#define PL_R_IF_ELSE (23) /* if(Cond, Then, Else) */
#define PL_R_FOR (26) /* for(I in Cond, Expr) */
#define PL_R_WHILE (27) /* while(Cond, Expr) */
#define PL_R_REPEAT (28) /* repeat(Expr) */
#define PL_R_NEXT (29) /* next */
#define PL_R_BREAK (30) /* break */
#define PL_R_IN (31) /* break */
#define PL_R_RFORMULA (32) /* ~ Exp */
#define PL_R_EQUAL (33) /* ~ Exp */
#define PL_R_VECTOR (256) /* [.....] * */
#define REAL_Error(s, t) REAL_Error__(__LINE__, __FUNCTION__, s, t)
static bool REAL_Error__(int line, const char *function, const char *s,
term_t t) {
term_t except = PL_new_term_ref();
PL_unify_term(except, PL_FUNCTOR_CHARS, "real_error", 2, PL_CHARS, s, PL_TERM,
t, PL_CHARS, function, PL_INT, line);
return PL_raise_exception(except);
}
#define _PL_get_arg PL_get_arg
#define Sdprintf(S, A1) fprintf(stderr, S, A1)
static size_t pos_dims(size_t R_index[], size_t ndims, size_t dims[]) {
int i, index = 0;
for (i = ndims - 1; i >= 0; i--) {
index = index * dims[i] + R_index[i] - 1;
}
return index;
}
static void inc_dims(size_t R_index[], size_t ndims, size_t dims[]) {
int i;
for (i = ndims - 1; i >= 0; i--) {
if (++R_index[i] <= dims[i])
return;
R_index[i] = 1;
}
}
static size_t sexp_rank(SEXP sexp) {
/* Return the number of dimensions for the buffer
* (e.g., a vector will return 1, a matrix 2, ...)
*/
/* Copied from rpy2 */
SEXP dim = getAttrib(sexp, R_DimSymbol);
if (dim == R_NilValue)
return 1;
return GET_LENGTH(dim);
}
/* Copied, with slight mods from rpy2 */
static int sexp_shape(SEXP sexp, size_t nd, size_t *shape) {
/* Set 'shape', containing the size of each dimension (see sexp_rank). */
int i;
SEXP dim = getAttrib(sexp, R_DimSymbol);
if (dim == R_NilValue)
shape[0] = LENGTH(sexp);
else
for (i = 0; i < nd; i++) {
shape[i] = INTEGER(dim)[i];
}
return TRUE;
}
/* get the list element named str, or return NULL */
static SEXP getListElement(SEXP list, const char *str) {
SEXP elmt = R_NilValue, names;
int i;
if (list == R_NilValue)
return R_NilValue;
names = getAttrib(list, R_NamesSymbol);
for (i = 0; i < length(list); i++)
if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
elmt = VECTOR_ELT(list, i);
break;
}
return elmt;
}
static int setListElement(term_t t, SEXP s_str, SEXP sexp) {
int i, hadError, nprotect = 0;
size_t shape;
SEXP names, name_R, call_R, p, list;
const char *str;
if (TYPEOF(s_str) == SYMSXP) {
s_str = PRINTNAME(s_str);
}
if (TYPEOF(s_str) == STRSXP) {
if (sexp_rank(s_str) > 1) {
Ureturn FALSE;
}
sexp_shape(s_str, 1, &shape);
if (shape != 1) {
Ureturn FALSE;
}
str = CHAR(CHARACTER_DATA(s_str)[0]);
} else {
Ureturn FALSE;
}
PROTECT_AND_COUNT(list = term_to_sexp(t, TRUE));
if (list == R_NilValue) {
Ureturn FALSE;
}
names = getAttrib(list, R_NamesSymbol);
for (i = 0; i < length(list); i++) {
if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
SET_ELEMENT(list, i, sexp);
Ureturn TRUE;
}
}
// new attribute,
// we need to work with the identifier
PROTECT_AND_COUNT(list = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(name_R = allocVector(STRSXP, 1));
SET_STRING_ELT(name_R, 0, mkCharCE(str, CE_UTF8));
PROTECT_AND_COUNT(call_R = lang3(R_DollarSymbol, list, name_R));
p = lang3(install("<-"), call_R, sexp);
(void)protected_tryEval(p, R_GlobalEnv, &hadError);
Ureturn TRUE;
}
static int complex_term(term_t head, double *valxP, double *valyP) {
term_t val1 = PL_new_term_ref();
atom_t name;
int arity;
if (PL_is_functor(head, FUNCTOR_plus2) && PL_get_arg(2, head, val1) &&
((PL_is_functor(val1, FUNCTOR_i1) && PL_get_arg(1, val1, val1) &&
PL_get_float(val1, valyP)) ||
(PL_get_name_arity(val1, &name, &arity) && name == ATOM_i &&
arity == 0 && (*valyP = 1, TRUE))) &&
PL_get_arg(1, head, head) && PL_get_float(head, valxP))
return TRUE;
if (PL_is_functor(head, FUNCTOR_minus2) && PL_get_arg(2, head, val1) &&
((PL_is_functor(val1, FUNCTOR_i1) && PL_get_arg(1, val1, val1) &&
PL_get_float(val1, valyP) && (*valyP = -*valyP, TRUE)) ||
(PL_get_name_arity(val1, &name, &arity) && name == ATOM_i &&
arity == 0 && (*valyP = -1, TRUE))) &&
PL_get_arg(1, head, head) && PL_get_float(head, valxP))
return 1;
return 0;
}
static int REAL_term_type(term_t t, int context) {
int objtype = PL_term_type(t), rc;
term_t tmp = PL_copy_term_ref(t);
functor_t f;
switch (objtype) {
case PL_VARIABLE:
return PL_R_VARIABLE;
case PL_INTEGER:
return PL_R_INTEGER;
case PL_FLOAT:
return PL_R_FLOAT;
case PL_STRING:
return PL_R_CHARS;
case PL_ATOM:
#ifdef PL_NIL
case PL_NIL:
#endif
{
int got_v = 0;
int bool_vP = 0;
atom_t tmp_atom;
if ((got_v = PL_get_bool(t, &bool_vP)))
return PL_R_BOOL;
if (!PL_get_atom(t, &tmp_atom))
REAL_Error("type atom", t);
if (tmp_atom == ATOM_true || tmp_atom == ATOM_false)
return PL_R_BOOL;
if (tmp_atom == ATOM_break)
return PL_R_BREAK;
if (tmp_atom == ATOM_next)
return PL_R_NEXT;
else if (context & PL_R_VECTOR)
return PL_R_CHARS;
else
return PL_R_SYMBOL;
} break;
case PL_TERM:
#ifdef PL_LIST_PAIR
case PL_LIST_PAIR:
#endif
{
term_t tail = PL_new_term_ref();
size_t len;
atom_t a;
int arity;
if (PL_LIST == PL_skip_list(t, tail, &len)) {
if (!PL_get_list(t, tmp, t)) {
return FALSE;
}
int rc = PL_R_VECTOR | REAL_term_type(tmp, context | PL_R_VECTOR);
return rc;
} else if (len > 0) {
// must be a dot term
return PL_R_DOT;
}
if (!PL_get_functor(t, &f))
return FALSE;
if ((context & PL_R_VECTOR) && f == FUNCTOR_equal2) {
return PL_R_NAME | PL_R_VECTOR;
}
if (!(context & PL_R_VECTOR) && f == FUNCTOR_dollar2) {
if (!PL_get_arg(2, t, tmp))
return FALSE;
return PL_R_LISTEL;
}
if (!(context & PL_R_VECTOR) && f == FUNCTOR_at2) {
if (!PL_get_arg(2, t, tmp))
return FALSE;
return PL_R_SLOT;
}
if (!(context & PL_R_VECTOR) && f == FUNCTOR_square_brackets2) {
return PL_R_SUBSET;
}
{
double x, y;
if (complex_term(t, &x, &y))
return PL_R_COMPLEX;
}
if (f == FUNCTOR_tilde2) {
return PL_R_FORMULA;
}
if (f == FUNCTOR_tilde1) {
return PL_R_RFORMULA;
}
if (f == FUNCTOR_plus1) {
if (!PL_get_arg(1, t, tmp))
return FALSE;
rc = REAL_term_type(tmp, context);
if (rc == PL_R_CHARS || rc == PL_R_SYMBOL)
return PL_R_PLUS;
return PL_R_CALL;
}
if (f == FUNCTOR_dot1) {
if (!PL_get_arg(1, t, tmp))
return FALSE;
rc = REAL_term_type(tmp, context);
if (rc == PL_R_DOT || rc == PL_R_SYMBOL)
return PL_R_DOT;
}
if (f == FUNCTOR_brackets1) {
if (!PL_get_arg(1, t, tmp))
return FALSE;
return PL_R_CALL;
}
if (f == FUNCTOR_equal2) {
return PL_R_EQUAL;
}
if (f == FUNCTOR_minus1 || f == FUNCTOR_dollar1) {
if (!PL_get_arg(1, t, tmp))
return FALSE;
rc = REAL_term_type(tmp, context);
if (rc == PL_R_CHARS || rc == PL_R_SYMBOL)
return PL_R_PSYMBOL;
return PL_R_CALL;
}
if (f == FUNCTOR_quote1)
return PL_R_QUOTE;
if (f == FUNCTOR_if2 && PL_get_arg(1, t, tmp) &&
PL_get_name_arity(tmp, &a, &arity) && a == ATOM_function)
return PL_R_DEFUN;
if (f == FUNCTOR_iff2)
return PL_R_IF;
if (f == FUNCTOR_in2)
return PL_R_IN;
if (f == FUNCTOR_iff3)
return PL_R_IF_ELSE;
if (f == FUNCTOR_while2)
return PL_R_WHILE;
if (f == FUNCTOR_repeat1)
return PL_R_REPEAT;
if (f == FUNCTOR_boolop1) {
if (!PL_get_arg(1, t, tmp))
return REAL_Error("argument access", t);
if (!PL_get_atom(tmp, &a))
return REAL_Error("type atom", t);
if (a == ATOM_true || a == ATOM_false)
return PL_R_BOOL;
}
return PL_R_CALL;
} break;
default:
return FALSE;
}
}
static int merge_dots(term_t t) {
char so[1025], *ns = so;
int loop = TRUE, first = TRUE, arity;
term_t tmp = PL_new_term_ref();
atom_t name;
so[0] = '\0';
while (loop) {
if (PL_get_list(t, tmp, t))
loop = TRUE;
else if ((PL_is_functor(t, FUNCTOR_dot1) && PL_get_arg(1, t, tmp)) ||
(tmp = t, TRUE))
loop = FALSE;
if (!first || !loop) {
strncat(so, ".", 1024);
}
if (first) {
first = FALSE;
}
if (PL_get_chars(tmp, &ns,
CVT_ATOM | CVT_STRING | BUF_DISCARDABLE | REP_UTF8)) {
ns += strlen(ns);
if (!loop) {
atom_t at = PL_new_atom(so);
return PL_put_atom(t, at);
}
} else if (!loop && PL_is_functor(t, FUNCTOR_brackets1) &&
PL_get_arg(1, t, tmp) &&
PL_get_chars(tmp, &ns, CVT_ATOM | CVT_STRING | BUF_DISCARDABLE |
REP_UTF8)) {
strncat(so, ns, 1024 - strlen(so) - 1);
return PL_put_atom_chars(tmp, so) &&
PL_cons_functor(t, FUNCTOR_brackets1, tmp);
} else if (!loop && PL_get_name_arity(tmp, &name, &arity) &&
(ns = PL_atom_chars(name))) {
strncat(so, ns, 1024 - strlen(so) - 1);
term_t a = PL_new_term_refs(arity);
int i;
for (i = 0; i < arity; i++)
if (!PL_get_arg(i + 1, tmp, a + i))
return FALSE;
return PL_cons_functor_v(t, PL_new_functor(PL_new_atom(so), arity), a);
} else
return FALSE;
}
return FALSE;
}
// put t in ans[index]; and stores elements of type objtype
static int term_to_S_el(term_t t, int objtype, size_t index, SEXP ans) {
switch (objtype) {
case PL_R_CHARS:
case PL_R_PLUS: {
char *s;
if (PL_get_chars(t, &s, CVT_ATOM | CVT_STRING | CVT_LIST | BUF_DISCARDABLE |
REP_UTF8)) {
CHARACTER_DATA(ans)[index] = mkCharCE(s, CE_UTF8);
return TRUE;
} else {
if (PL_get_arg(1, t, t) &&
PL_get_chars(t, &s, CVT_ATOM | CVT_STRING | CVT_LIST |
BUF_DISCARDABLE | REP_UTF8)) {
CHARACTER_DATA(ans)[index] = mkCharCE(s, CE_UTF8);
return TRUE;
}
}
}
return FALSE;
case PL_R_INTEGER: {
int64_t val;
if (PL_get_int64(t, &val)) {
INTEGER_DATA(ans)[index] = val;
} else {
return FALSE;
}
} break;
case PL_R_FLOAT: {
double val;
int64_t ival;
if (PL_get_float(t, &val)) {
NUMERIC_DATA(ans)[index] = val;
return TRUE;
} else if (PL_get_int64(t, &ival)) {
NUMERIC_DATA(ans)[index] = ival;
return TRUE;
} else
return FALSE;
} break;
case PL_R_ATBOOL:
case PL_R_BOOL: {
int val;
if (PL_get_bool(t, &val)) {
LOGICAL_DATA(ans)[index] = val;
return TRUE;
} else {
if (PL_get_arg(1, t, t) && PL_get_bool(t, &val)) {
LOGICAL_DATA(ans)[index] = val;
return TRUE;
}
return FALSE;
}
} break;
case PL_R_COMPLEX: {
double valx, valy, val;
int64_t ival;
if (complex_term(t, &valx, &valy)) {
COMPLEX_DATA(ans)[index].r = valx;
COMPLEX_DATA(ans)[index].i = valy;
return TRUE;
} else if (PL_get_float(t, &val)) {
COMPLEX_DATA(ans)[index].r = val;
COMPLEX_DATA(ans)[index].i = 0.0;
return TRUE;
} else if (PL_get_int64(t, &ival)) {
COMPLEX_DATA(ans)[index].r = ival;
COMPLEX_DATA(ans)[index].i = 0.0;
return TRUE;
} else { /* FIXME: Destroy ans */
return FALSE; /* type error */
}
}
break;
default:
assert(0);
}
return TRUE;
}
// put t in ans[index]; and stores elements of type objtype
static int sexp_to_S_el(SEXP sin, size_t index, SEXP ans) {
switch (TYPEOF(ans)) {
case STRSXP: {
if (TYPEOF(sin) != STRSXP)
return FALSE;
CHARACTER_DATA(ans)[index] = CHARACTER_DATA(sin)[0];
} break;
case INTSXP: {
if (TYPEOF(sin) != INTSXP)
return FALSE;
INTEGER_DATA(ans)[index] = INTEGER_DATA(sin)[0];
} break;
case REALSXP: {
if (TYPEOF(sin) == INTSXP)
NUMERIC_DATA(ans)[index] = INTEGER_DATA(sin)[0];
else if (TYPEOF(sin) == REALSXP)
NUMERIC_DATA(ans)[index] = NUMERIC_DATA(sin)[0];
else
return FALSE;
} break;
case LGLSXP: {
if (TYPEOF(sin) == LGLSXP)
LOGICAL_DATA(ans)[index] = LOGICAL_DATA(sin)[0];
else
return FALSE;
break;
}
case CPLXSXP: {
if (TYPEOF(sin) == CPLXSXP) {
COMPLEX_DATA(ans)[index] = COMPLEX_DATA(sin)[0];
} else if (TYPEOF(sin) == INTSXP) {
COMPLEX_DATA(ans)[index].r = INTEGER_DATA(sin)[0];
COMPLEX_DATA(ans)[index].i = 0;
} else if (TYPEOF(sin) == REALSXP) {
COMPLEX_DATA(ans)[index].r = NUMERIC_DATA(sin)[0];
COMPLEX_DATA(ans)[index].i = 0;
} else
return FALSE;
} break;
case VECSXP: {
SEXPTYPE type = TYPEOF(sin);
switch (type) {
case CPLXSXP:
case INTSXP:
case REALSXP:
VECTOR_DATA(ans)[index] = Rf_coerceVector(sin, type);
break;
case VECSXP:
VECTOR_DATA(ans)[index] = VECTOR_DATA(sin)[0];
break;
default:
return FALSE;
}
} break;
default:
assert(0);
}
return 1;
}
static int set_listEl_to_sexp(term_t t, SEXP sexp) {
term_t tslot = PL_new_term_ref();
SEXP s;
int nprotect = 0;
if (!PL_get_arg(2, t, tslot))
return FALSE;
if (PL_is_pair(tslot) || PL_is_functor(tslot, FUNCTOR_dot1)) {
if (!merge_dots(tslot))
return FALSE;
}
s = term_to_sexp(tslot, FALSE);
if (!PL_get_arg(1, t, t))
Ureturn FALSE;
// we now have s with the slot, and tmp_R with the object. Let us roll..
return setListElement(t, s, sexp);
}
static SEXP list_to_sexp(term_t t, int objtype) {
term_t tail = PL_new_term_ref(), tmp = PL_copy_term_ref(t);
size_t dims[256];
term_t stack[256];
size_t R_index[256];
size_t ndims = 0, len, spos = 0;
int nprotect = 0, i, sobjtype;
SEXP ans;
// cheking the depth of the list
tmp = PL_copy_term_ref(tmp);
while (PL_is_pair(tmp)) {
size_t len;
if (PL_LIST != PL_skip_list(tmp, tail, &len)) {
Ureturn R_NilValue;
}
if (!PL_get_list(tmp, tmp, tail)) {
Ureturn R_NilValue;
}
dims[ndims] = len;
ndims++;
}
for (i = 0, len = 1; i < ndims; i++) {
len *= dims[i];
}
if ((objtype & ~PL_R_VECTOR) == PL_R_NAME) {
SEXP names;
int nprotect = 0;
PROTECT_AND_COUNT(ans = NEW_LIST(len));
PROTECT_AND_COUNT(names = allocVector(STRSXP, len));
for (i = 0; PL_get_list(t, tmp, t); i++) {
if (PL_is_functor(tmp, FUNCTOR_equal2)) {
char *nm = NULL;
SEXP sexp;
if (PL_get_arg(1, tmp, tail) && PL_get_arg(2, tmp, tmp) &&
(PL_is_pair(tail) || PL_is_functor(tail, FUNCTOR_dot1)) &&
merge_dots(tail) &&
PL_get_chars(tail, &nm,
CVT_ATOM | CVT_STRING | BUF_MALLOC | REP_UTF8)) {
sexp = term_to_sexp(tmp, FALSE);
SET_STRING_ELT(names, i, mkCharCE(nm, CE_UTF8));
SET_ELEMENT(ans, i, sexp);
PL_free(nm);
} else if ((PL_is_atom(tail) || PL_is_string(tail)) &&
PL_get_chars(tail, &nm, CVT_ATOM | CVT_STRING | BUF_MALLOC |
REP_UTF8)) {
sexp = term_to_sexp(tmp, FALSE);
SET_STRING_ELT(names, i, mkCharCE(nm, CE_UTF8));
SET_ELEMENT(ans, i, sexp);
PL_free(nm);
/* also check cases like java.parameters */
} else { /* FIXME: Destroy ans and names */
if (nm)
PL_free(nm);
Ureturn ans;
}
} else { /* */
REAL_Error("type list", tmp);
Ureturn ans;
}
}
SET_NAMES(ans, names);
Ureturn ans;
} else {
sobjtype = objtype & ~PL_R_VECTOR;
}
switch (sobjtype) {
case PL_R_INTEGER:
PROTECT_AND_COUNT(ans = NEW_INTEGER(len));
break;
case PL_R_FLOAT:
PROTECT_AND_COUNT(ans = NEW_NUMERIC(len));
break;
case PL_R_CHARS:
case PL_R_PLUS:
PROTECT_AND_COUNT(ans = NEW_CHARACTER(len));
break;
case PL_R_COMPLEX:
PROTECT_AND_COUNT(ans = NEW_COMPLEX(len));
break;
case PL_R_ATBOOL:
case PL_R_BOOL:
PROTECT_AND_COUNT(ans = NEW_LOGICAL(len));
break;
default:
assert(0);
}
// take care of dims
SEXP sdims = NEW_INTEGER(ndims);
for (i = 0; i < ndims; i++) {
INTEGER_DATA(sdims)[i] = dims[i];
R_index[i] = 1; // use R notation
}
setAttrib(ans, R_DimSymbol, sdims);
stack[0] = PL_copy_term_ref(t);
term_t l = stack[0];
for (i = 1; i <= ndims; i++)
stack[i] = PL_new_term_ref();
while (TRUE) {
if (PL_is_pair(l)) {
PL_get_list(l, stack[spos + 1], l);
l = stack[spos + 1];
spos++;
} else if (PL_is_list(l)) {
if (spos == 0)
break;
l = stack[spos - 1];
spos--;
} else {
if (!term_to_S_el(l, objtype & ~PL_R_VECTOR,
pos_dims(R_index, ndims, dims), ans)) {
if ((objtype & PL_R_INTEGER) && PL_is_float(l)) {
Ureturn list_to_sexp(t, PL_R_FLOAT | PL_R_VECTOR);
}
Ureturn R_NilValue;
}
inc_dims(R_index, ndims, dims);
l = stack[spos - 1];
spos--;
}
}
Ureturn ans;
}
static int slot_to_sexp(term_t t, SEXP *ansP) {
term_t tslot = PL_new_term_ref();
char *s;
SEXP tmp_R, name_R;
int nprotect = 0;
if (!PL_get_arg(2, t, tslot))
return FALSE;
if (PL_is_pair(tslot) || PL_is_functor(tslot, FUNCTOR_dot1)) {
if (!merge_dots(tslot))
return FALSE;
}
if (!PL_get_chars(tslot, &s, CVT_ATOM | BUF_MALLOC | REP_UTF8)) {
return FALSE;
}
if (!PL_get_arg(1, t, t))
return FALSE;
PROTECT_AND_COUNT(tmp_R = term_to_sexp(t, TRUE));
// we now have s with the slot, and tmp_R with the object. Let us roll..
PROTECT_AND_COUNT(name_R = install(s));
if (!R_has_slot(tmp_R, name_R)) {
return FALSE;
}
*ansP = GET_SLOT(tmp_R, name_R);
if (!*ansP)
return FALSE;
return TRUE;
}
static int set_slot_to_sexp(term_t t, SEXP sexp) {
term_t tslot = PL_new_term_ref();
char *s;
SEXP tmp_R, name_R;
int nprotect = 0;
if (!PL_get_arg(2, t, tslot))
return FALSE;
if (PL_is_pair(tslot) || PL_is_functor(tslot, FUNCTOR_dot1)) {
if (!merge_dots(tslot))
return FALSE;
}
if (!PL_get_chars(tslot, &s, CVT_ATOM | BUF_MALLOC | REP_UTF8)) {
return FALSE;
}
if (!PL_get_arg(1, t, t))
return FALSE;
PROTECT_AND_COUNT(tmp_R = term_to_sexp(t, TRUE));
// we now have s with the slot, and tmp_R with the object. Let us roll..
PROTECT_AND_COUNT(name_R = install(s));
// if (! R_has_slot(tmp_R, name_R)) {
// return FALSE;
//}
SET_SLOT(tmp_R, name_R, sexp);
Ureturn TRUE;
}
static int listEl_to_sexp(term_t t, SEXP *ansP) {
term_t tslot = PL_new_term_ref();
char *s;
SEXP tmp_R;
int nprotect = 0;
if (!PL_get_arg(2, t, tslot))
return FALSE;
if (PL_is_pair(tslot) || PL_is_functor(tslot, FUNCTOR_dot1)) {
if (!merge_dots(tslot))
return FALSE;
}
if (!PL_get_chars(tslot, &s, CVT_ATOM | BUF_MALLOC | REP_UTF8)) {
return FALSE;
}
if (!PL_get_arg(1, t, t))
return FALSE;
PROTECT_AND_COUNT(tmp_R = term_to_sexp(t, TRUE));
// we now have s with the slot, and tmp_R with the object. Let us roll..
*ansP = getListElement(tmp_R, s);
if (*ansP == R_NilValue)
Ureturn FALSE;
Ureturn TRUE;
}
static SEXP pl_to_func(term_t t, bool eval) {
atom_t name;
int arity;
term_t a1 = PL_new_term_ref(), a;
int i, ierror;
SEXP c_R, call_R, res_R;
char *sf;
int nprotect = 0;
if (!PL_get_name_arity(t, &name, &arity)) {
Ureturn FALSE;
}
if (!(sf = PL_atom_chars(name))) {
Ureturn FALSE;
}
if (!strcmp(sf, "()")) {
if (!PL_get_arg(1, t, a1) ||
!PL_get_chars(a1, &sf, CVT_ATOM | BUF_MALLOC | REP_UTF8)) {
Ureturn FALSE;
}
arity = 0;
}
// first evaluate arguments left to right
a = PL_new_term_ref(), a1 = PL_new_term_ref();
PROTECT_AND_COUNT(call_R = allocList(arity + 1));
c_R = call_R;
c_R = CDR(c_R);
for (i = 0; i < arity; i++) {
if (!PL_get_arg(i + 1, t, a)) {
REAL_Error("argument access", t);
{ Ureturn R_NilValue; }
}
if (PL_is_functor(a, FUNCTOR_equal2)) {
char *s = NULL;
if (!PL_get_arg(1, a, a1)) {
Ureturn FALSE;
}
if (PL_is_pair(a1) || PL_is_functor(a1, FUNCTOR_dot1)) {
if (!merge_dots(a1)) {
Ureturn FALSE;
}
}
if (!PL_get_chars(a1, &s,
CVT_ATOM | CVT_STRING | BUF_MALLOC | REP_UTF8)) {
Ureturn FALSE;
}
if (!PL_get_arg(2, a, a)) {
Ureturn FALSE;
}
SETCAR(c_R, term_to_sexp(a, FALSE));
SET_TAG(c_R, install(s));
PL_free(s);
} else {
SETCAR(c_R, term_to_sexp(a, FALSE));
}
c_R = CDR(c_R);
}
// now we can evaluate the function
if (arity == 1) {
SEXP mu;
PROTECT_AND_COUNT(mu = getAttrib(CADR(call_R), install(sf)));
if (!(mu == R_UnboundValue || mu == R_NilValue)) {
// PL_free( sf );
{ Ureturn mu; }
}
}
c_R = call_R;
// PROTECT_AND_COUNT( fn_R = myFindFun(install(sf), R_GlobalEnv) );
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, install(sf));
// PL_free( sf );
if (eval) {
PROTECT_AND_COUNT(res_R = protected_tryEval(call_R, R_GlobalEnv, &ierror));
if (res_R == NULL)
res_R = call_R;
{ Ureturn res_R; }
}
Ureturn call_R;
}
static int pl_to_body(term_t t, SEXP *ansP) {
term_t tmp = PL_copy_term_ref(t), tail = PL_copy_term_ref(t);
size_t i, len;
SEXP body_R;
int nprotect = 0;
if (PL_LIST == PL_skip_list(tmp, tail, &len)) {
SEXP ans, stmp;
PROTECT_AND_COUNT(ans = stmp = allocList(len));
for (i = 0; i < len; i++) {
if (!PL_get_list(t, tmp, t)) {
Ureturn FALSE;
}
PROTECT_AND_COUNT(body_R = term_to_sexp(t, FALSE));
SETCAR(stmp, body_R);
stmp = CDR(stmp);
}
*ansP = ans;
} else {
PROTECT_AND_COUNT(*ansP = term_to_sexp(t, FALSE));
if (Rf_isNull(*ansP)) {
Ureturn FALSE;
}
}
Ureturn TRUE;
}
static int pl_to_defun(term_t t, SEXP *ansP) {
atom_t name;
int arity;
term_t a = PL_new_term_ref(), body = PL_new_term_ref();
int i;
SEXP clo_R, c_R, call_R, body_R;
int nprotect = 0;
if (!PL_get_arg(1, t, a)) {
Ureturn FALSE;
}
if (!PL_get_name_arity(a, &name, &arity)) {
Ureturn FALSE;
}
if (!PL_get_arg(2, t, body)) {
Ureturn FALSE;
}
PROTECT_AND_COUNT(clo_R = allocSExp(CLOSXP));
if (!clo_R) {
Ureturn FALSE;
}
PROTECT_AND_COUNT(c_R = call_R = allocList(arity));
SET_TYPEOF(c_R, LANGSXP);
for (i = 0; i < arity; i++) {
SEXP tmp_R;
if (!PL_get_arg(i + 1, a, t)) {
Ureturn REAL_Error("argument access", t);
}
PROTECT_AND_COUNT(tmp_R = term_to_sexp(t, FALSE));
if (Rf_isNull(tmp_R)) {
Ureturn FALSE;
}
SETCAR(c_R, tmp_R);
SET_TAG(c_R, CreateTag(tmp_R));
c_R = CDR(c_R);
}
SET_FORMALS(clo_R, call_R);
SET_CLOENV(clo_R, R_GlobalEnv);
if (!pl_to_body(body, &body_R)) {
Ureturn FALSE;
}
SET_BODY(clo_R, body_R);
*ansP = clo_R;
Ureturn TRUE;
}
static int old_list_to_sexp(term_t t, SEXP c_R, int n, bool eval) {
int i;
term_t a = PL_new_term_ref();
SEXP head_R;
int nprotect = 0;
for (i = 0; i < n; i++) {
if (PL_get_list(t, a, t)) {
if (PL_is_variable(a)) {
SETCAR(c_R, R_MissingArg);
} else {
PROTECT_AND_COUNT(head_R = term_to_sexp(a, eval));
SETCAR(c_R, head_R);
}
c_R = CDR(c_R);
} else {
Ureturn FALSE;
}
}
Ureturn TRUE;
}
static SEXP subset_to_sexp(term_t t, bool eval) {
term_t a = PL_new_term_ref(), b = PL_new_term_ref();
SEXP lhs_R, call_R, res_R, sin, c_R;
int nprotect = 0;
int ierror;
size_t len;
// get lh side
if (!PL_get_arg(2, t, a)) {
REAL_Error("argument access", t);
Ureturn R_NilValue;
}
PROTECT_AND_COUNT(lhs_R = term_to_sexp(a, eval));
if (Rf_isNull(lhs_R)) {
Ureturn R_NilValue;
}
// get index
if (!PL_get_arg(1, t, a)) {
REAL_Error("argument access", t);
Ureturn R_NilValue;
}
if (PL_get_list(a, t, b) && PL_is_pair(t) &&
PL_get_nil(b)) { /* [[ operator */
sin = R_Bracket2Symbol;
a = t;
} else {
sin = R_BracketSymbol; // [ operator
}
if (PL_skip_list(a, b, &len) != PL_LIST) {
Ureturn R_NilValue;
}
PROTECT_AND_COUNT(call_R = allocList(len + 2));
c_R = call_R;
SETCAR(c_R, sin);
SET_TYPEOF(c_R, LANGSXP);
c_R = CDR(c_R);
SETCAR(c_R, lhs_R);
c_R = CDR(c_R);
if (!old_list_to_sexp(a, c_R, len, FALSE)) {
Ureturn R_NilValue;
}
SEXP ans;
if (eval) {
PROTECT_AND_COUNT(res_R = protected_tryEval(call_R, R_GlobalEnv, &ierror));
if (ierror) {
Ureturn call_R;
}
ans = res_R;
} else {
ans = call_R;
}
Ureturn ans;
}
static int set_subset_eval(SEXP symbol, term_t a, SEXP lhs_R, SEXP sexp) {
int hadError;
SEXP p, call_R, index_R, c_R, sin;
term_t f, b;
int nprotect = 0;
size_t len;
f = PL_new_term_ref();
b = PL_new_term_ref();
if (PL_get_list(a, b, f) && PL_is_pair(b) &&
PL_get_nil(f)) { /* [[ operator ]] */
sin = R_Bracket2Symbol;
a = b;
} else {
sin = R_BracketSymbol; // [ operator
}
if (PL_skip_list(a, b, &len) != PL_LIST) {
Ureturn FALSE;
}
PROTECT_AND_COUNT(c_R = index_R = allocList(len + 1));
SETCAR(c_R, sin);
SET_TYPEOF(c_R, LANGSXP);
c_R = CDR(c_R);
if (!old_list_to_sexp(a, c_R, len, TRUE)) {
{ Ureturn 0; }
}
PROTECT_AND_COUNT(call_R = LCONS(symbol, CONS(lhs_R, index_R)));
SET_TYPEOF(call_R, LANGSXP);
PROTECT_AND_COUNT(p = lang3(install("<-"), call_R, sexp));
(void)protected_tryEval(p, R_GlobalEnv, &hadError);
{ Ureturn hadError; }
}
static int set_subset_to_sexp(term_t t, SEXP sexp) {
term_t a = PL_new_term_ref();
SEXP lhs_R;
int i = 0;
size_t dims[256], indexi[256], ndims, index;
int nprotect = 0;
if (!PL_get_arg(1, t, a))
return REAL_Error("argument access", t);
if (!PL_get_arg(2, t, t))
return REAL_Error("argument access", t);
term_t t0 = PL_copy_term_ref(t);
term_t a0 = PL_copy_term_ref(a);
while (PL_get_list(a, t, a)) {
int64_t j;
if (!PL_get_int64(t, &j)) {
PROTECT_AND_COUNT(lhs_R = term_to_sexp(t0, FALSE));
return set_subset_eval(R_BracketSymbol, a0, lhs_R, sexp);
}
indexi[i] = j;
i++;
}
PROTECT_AND_COUNT(lhs_R = term_to_sexp(t0, TRUE));
ndims = sexp_rank(lhs_R);
sexp_shape(lhs_R, ndims, dims);
if (i != ndims)
Ureturn FALSE;
index = pos_dims(indexi, ndims, dims);
Ureturn sexp_to_S_el(sexp, index, lhs_R);
}
static int pl_to_unary(const char *s, term_t t, SEXP *ansP) {
int nprotect = 0;
if (!PL_get_arg(1, t, t)) {
Ureturn FALSE;
}
PROTECT_AND_COUNT(*ansP = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(*ansP = lang2(install(s), *ansP));
Ureturn TRUE;
}
static int pl_to_binary(const char *s, term_t t, term_t tmp, SEXP *ansP) {
int nprotect = 0;
SEXP sexp;
if (!PL_get_arg(2, t, tmp)) {
return FALSE;
}
if (!PL_get_arg(1, t, t)) {
return FALSE;
}
PROTECT_AND_COUNT(*ansP = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(sexp = term_to_sexp(tmp, FALSE));
PROTECT_AND_COUNT(*ansP = lang3(install(s), *ansP, sexp));
Ureturn TRUE;
}
/**
* term_to_sexp: convert a Prolog term to an R sexp
*
* @param t the Prolog term
* @param ansP a pointer to the result SEXP
* @param eval whether to evaluate functions, eg, whether `2+3` should
* be converted to `closure(+,[[2],[3]))` or to `5`.
*
* @return whether it succeeds or fails.
*/
static SEXP(term_to_sexp(term_t t, bool eval)) {
int nprotect = 0;
SEXP ans = R_NilValue;
int objtype;
term_t tmp = PL_copy_term_ref(t);
int rc;
objtype = REAL_term_type(tmp, 0);
if (objtype & PL_R_VECTOR) {
PROTECT_AND_COUNT(ans = list_to_sexp(t, objtype));
rc = (ans != R_NilValue);
} else
switch (objtype) {
/// free variable is translated to an argument that can take
/// any value, eg:
/// `[_,2]` corresponds to `[,2]` in R selectors
/// `X ~ _` corresponds tp `X ~ .` in R formulas
case PL_R_VARIABLE:
ans = R_MissingArg;
rc = true;
break;
/// +'Atom' or "string" to R 'string' or CHARACTER object
///
/// real suggest using "..." notation for strings,
/// but `string` will work as well.
///
/// @deprecated +atom is an hack, and should be avoided
case PL_R_PLUS:
case PL_R_CHARS:
PROTECT_AND_COUNT(ans = NEW_CHARACTER(1));
rc = term_to_S_el(t, PL_R_CHARS, 0, ans);
break;
/// Prolog -atom or -"symbol" matches to R symbol
///
/// @deprecated not needed any longer
case PL_R_PSYMBOL:
rc = PL_get_arg(1, t, t);
/// Prolog atom matches to R symbol
///
/// atoms can be evaluated
case PL_R_SYMBOL: {
char *s = NULL;
if ((rc = PL_get_chars(t, &s, CVT_ATOM | CVT_STRING | BUF_DISCARDABLE |
REP_UTF8))) {
if (eval) {
PROTECT_AND_COUNT(ans = findVar(Rf_install(s), R_GlobalEnv));
} else {
PROTECT_AND_COUNT(ans = Rf_install(s)); // NEW_CHARACTER(1));
// if ( ! term_to_S_el( t, PL_R_CHARS, 0, ans) )
// Ureturn 0;
}
if (ans == R_UnboundValue) {
rc = false;
}
}
} break;
/// YAP supports . as an infix operator, so a.b can be converted into R's
/// 'a.b'
///
case PL_R_DOT:
rc = merge_dots(t);
PROTECT_AND_COUNT(ans = term_to_sexp(t, eval));
break;
/// integer basic type
case PL_R_INTEGER:
PROTECT_AND_COUNT(ans = NEW_INTEGER(1));
rc = term_to_S_el(t, PL_R_INTEGER, 0, ans);
break;
/// float basic type
case PL_R_FLOAT:
PROTECT_AND_COUNT(ans = NEW_NUMERIC(1));
rc = term_to_S_el(t, PL_R_FLOAT, 0, ans);
break;
/// boolean in real is true or 'TRUE', false or 'FALSE'
case PL_R_BOOL:
PROTECT_AND_COUNT(ans = NEW_LOGICAL(1));
rc = term_to_S_el(t, PL_R_BOOL, 0, ans);
break;
/// X$E access a named attribute from a list (ie. an attribute)
case PL_R_LISTEL: {
rc = listEl_to_sexp(t, &ans);
} break;
/// O@S access a slot from an object
case PL_R_SLOT: {
rc = slot_to_sexp(t, &ans);
} break;
/// [...] selects a subset from a vector
case PL_R_SUBSET: {
ans = subset_to_sexp(t, eval);
rc = (ans != R_NilValue && ans != R_UnboundValue);
} break;
/// = applied in code definition,
///
/// currently never evaluated
case PL_R_EQUAL: {
tmp = PL_new_term_ref();
rc = pl_to_binary("=", t, tmp, &ans);
} break;
/// function call or closure
case PL_R_CALL: {
PROTECT_AND_COUNT(ans = pl_to_func(t, eval));
if (ans && !Rf_isNull(ans)) {
rc = true;
} else {
rc = false;
}
}
break;
/// fuction definition (yes, you can write R code as a Prolog term)
case PL_R_DEFUN: {
rc = pl_to_defun(t, &ans);
} break;
/// (X -> Y)
case PL_R_IF: {
term_t tcond = PL_new_term_ref();
SEXP cond, expr;
if ((rc = PL_get_arg(1, t, tcond))) {
PROTECT_AND_COUNT(cond = term_to_sexp(tcond, FALSE));
}
if (rc && PL_get_arg(2, t, t) && pl_to_body(t, &expr)) {
PROTECT_AND_COUNT(ans = LCONS(cond, expr));
}
} break;
/// if(Then, Else)
case PL_R_IF_ELSE: {
term_t tcond = PL_new_term_ref();
SEXP cond, sthen, selse;
if ((rc = PL_get_arg(1, t, tcond))) {
PROTECT_AND_COUNT(cond = term_to_sexp(tcond, FALSE));
if (PL_get_arg(2, t, tcond) && pl_to_body(tcond, &sthen) &&
PL_get_arg(3, t, t) && pl_to_body(t, &selse)) {
PROTECT_AND_COUNT(ans = lang4(install("if"), cond, sthen, selse));
}
}
break;
/// in(Cond, Expr)
case PL_R_IN: {
term_t tcond = PL_new_term_ref();
SEXP cond, expr;
if ((rc = PL_get_arg(1, t, tcond))) {
PROTECT_AND_COUNT(cond = term_to_sexp(tcond, FALSE));
if ((rc = PL_get_arg(2, t, t))) {
PROTECT_AND_COUNT(expr = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(ans = lang3(install("in"), cond, expr));
}
}
break;
/// while(Cond, Expr)
case PL_R_WHILE: {
term_t tcond = PL_new_term_ref();
SEXP cond, expr;
PROTECT_AND_COUNT(cond = term_to_sexp(tcond, FALSE));
if ((rc = PL_get_arg(2, t, t))) {
PROTECT_AND_COUNT(expr = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(ans = lang3(install("while"), cond, expr));
}
}
}
} break;
/// reepeat( Expr)
case PL_R_REPEAT: {
SEXP expr;
if ((rc = PL_get_arg(1, t, t) && pl_to_body(t, &expr))) {
PROTECT_AND_COUNT(ans = lang2(install("repeat"), expr));
}
} break;
/// break
case PL_R_BREAK: {
PROTECT_AND_COUNT(ans = lang1(install("break")));
}
rc = true;
break;
/// next
case PL_R_NEXT: {
PROTECT_AND_COUNT(ans = lang1(install("next")));
}
rc = true;
break;
// binary formula X ~ _
case PL_R_FORMULA: {
if ((rc = PL_get_arg(2, t, tmp))) {
if (PL_is_variable(tmp)) {
if ((rc = PL_get_arg(1, t, t))) {
PROTECT_AND_COUNT(ans = lang3(install("~"), *&ans, install(".")));
}
} else {
rc = pl_to_binary("~", t, tmp, &ans);
}
}
} break;
// unary formula ~ _
case PL_R_RFORMULA:
if ((rc = PL_get_arg(1, t, tmp))) {
if (PL_is_variable(tmp)) {
PROTECT_AND_COUNT(ans = term_to_sexp(t, FALSE));
PROTECT_AND_COUNT(ans = lang2(install("~"), install(".")));
}
} else {
rc = pl_to_unary("~", tmp, &ans);
}
break;
case PL_R_QUOTE: {
rc = PL_get_arg(1, t, t);
PROTECT_AND_COUNT(ans = term_to_sexp(t, TRUE));
} break;
case PL_R_OUTER:
rc = pl_to_binary("%o%", t, tmp, &ans);
break;
case PL_R_INNER: {
rc = pl_to_binary("%i%", t, tmp, &ans);
} break;
default:
assert(0);
rc = false;
}
PL_reset_term_refs(tmp);
Ureturn ans;
}
//
// Prolog to SEXP
//
static int bind_sexp(term_t t, SEXP sexp) {
int nprotect = 0;
int objtype;
objtype = REAL_term_type(t, 0);
if (objtype & PL_R_VECTOR) {
return FALSE;
}
switch (objtype) {
case PL_R_VARIABLE:
break;
case PL_R_BOOL: {
int b;
size_t n;
return sexp_rank(sexp) == 1 && sexp_shape(sexp, 0, &n) && n == 1 &&
TYPEOF(sexp) == LGLSXP && PL_get_bool(t, &b) &&
b == LOGICAL(sexp)[0];
}
case PL_R_FLOAT: {
double dbl;
size_t n;
return sexp_rank(sexp) == 1 && sexp_shape(sexp, 0, &n) && n == 1 &&
TYPEOF(sexp) == REALSXP && PL_get_float(t, &dbl) &&
dbl == REAL(sexp)[0];
}
case PL_R_INTEGER: {
size_t n;
int64_t i;
return sexp_rank(sexp) == 1 && sexp_shape(sexp, 0, &n) && n == 1 &&
TYPEOF(sexp) == INTSXP && PL_get_int64(t, &i) &&
i == INTEGER(sexp)[0];
}
case PL_R_COMPLEX:
case PL_R_PLUS:
case PL_R_CHARS:
return FALSE;
case PL_R_CALL: {
// look only for attributes
int arity;
atom_t name;
SEXP tmp_R;
const char *s;
if (!PL_get_name_arity(t, &name, &arity) || arity != 1) {
return FALSE;
}
if (!(s = PL_atom_chars(name))) {
return FALSE;
}
if (!PL_get_arg(1, t, t)) {
return FALSE;
}
PROTECT_AND_COUNT(tmp_R = term_to_sexp(t, TRUE));
if (Rf_isNull(tmp_R)) {
Ureturn FALSE;
}
// these two are tricky...
if (sexp_rank(tmp_R) == 1) {
if (!strcmp(s, "rownames")) {
SEXP dimnames, ans;
PROTECT_AND_COUNT(dimnames = allocVector(VECSXP, 1));
if (!Rf_isNull(sexp)) {
size_t i, n = Rf_length(sexp);
PROTECT_AND_COUNT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++)
SET_STRING_ELT(ans, i, STRING_ELT(sexp, i));
SET_VECTOR_ELT(dimnames, 0, ans);
}
dimnamesgets(tmp_R, dimnames);
}
}
if (!strcmp(s, "colnames")) {
SEXP dimnames, old, ans;
PROTECT_AND_COUNT(dimnames = allocVector(VECSXP, 2));
PROTECT_AND_COUNT(old =
Rf_GetRowNames(getAttrib(tmp_R, R_DimNamesSymbol)));
SET_VECTOR_ELT(dimnames, 0, old);
if (!isNull(sexp)) {
size_t i, n = Rf_length(sexp);
PROTECT_AND_COUNT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++)
SET_STRING_ELT(ans, i, STRING_ELT(sexp, i));
SET_VECTOR_ELT(dimnames, 1, ans);
}
dimnamesgets(tmp_R, dimnames);
Ureturn true;
} else if (!strcmp(s, "rownames")) {
SEXP dimnames, old, ans;
PROTECT_AND_COUNT(dimnames = allocVector(VECSXP, 2));
PROTECT_AND_COUNT(old =
Rf_GetColNames(getAttrib(tmp_R, R_DimNamesSymbol)));
SET_VECTOR_ELT(dimnames, 1, old);
if (!Rf_isNull(sexp)) {
size_t i, n = Rf_length(sexp);
PROTECT_AND_COUNT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++)
SET_STRING_ELT(ans, i, STRING_ELT(sexp, i));
SET_VECTOR_ELT(dimnames, 0, ans);
dimnamesgets(tmp_R, dimnames);
}
Ureturn true;
}
// we don't really care about it,
// there is an atribute
setAttrib(tmp_R, install(s), sexp);
return true;
}
case PL_R_PSYMBOL:
if (!PL_get_arg(1, t, t)) {
return FALSE;
}
break;
case PL_R_SYMBOL: {
char *s = NULL;
if (PL_get_chars(t, &s,
CVT_ATOM | CVT_STRING | BUF_DISCARDABLE | REP_UTF8)) {
defineVar(Rf_install(s), sexp, R_GlobalEnv);
}
break;
}
return 0;
case PL_R_LISTEL:
return set_listEl_to_sexp(t, sexp);
case PL_R_SLOT:
return set_slot_to_sexp(t, sexp);
case PL_R_DOT:
if (!merge_dots(t))
return FALSE;
return bind_sexp(t, sexp);
case PL_R_SUBSET:
return set_subset_to_sexp(t, sexp);
default:
assert(0);
}
{ Ureturn TRUE; }
}
/*
static foreign_t
pl_rtest1(term_t t)
{ SEXP sexp;
if ( ( , &sexp) )
{ PrintValue(sexp);
return TRUE;
}
return FALSE;
}
static foreign_t
pl_rtest2(term_t t = term_to_sexp(t, term_t out) )
{ SEXP sexp;
if ( ( , &sexp) )
{ term_t tmp = PL_new_term_ref();
if ( sexp_to_pl(tmp = term_to_sexp(t, sexp) ) )
return PL_unify(out, tmp);
}
return FALSE;
}
PL_register_foreign("rtest", 1, pl_rtest1, 0);
PL_register_foreign("rtest", 2, pl_rtest2, 0);
*/
/*******************************
* SEXP --> Prolog *
*******************************/
static int sexp_to_pl(term_t t, SEXP s) {
int rank = sexp_rank(s);
size_t shape[256];
if (rank > 2)
return REAL_Error("multi-dimensional arrays unsupported", t);
sexp_shape(s, rank, shape);
switch (rank) {
case 1: {
int i;
switch (TYPEOF(s)) {
case NILSXP:
PL_put_nil(t);
return TRUE;
case SYMSXP:
/* FIXME: take it as as an atom */
s = PRINTNAME(s);
if (TYPEOF(s) == STRSXP) {
size_t shape;
if (sexp_rank(s) > 1)
return FALSE;
sexp_shape(s, 1, &shape);
if (shape != 1)
return FALSE;
return PL_unify_chars(t, PL_ATOM | REP_UTF8, -1,
CHAR(CHARACTER_DATA(s)[0]));
}
return FALSE;
case REALSXP: {
term_t head = PL_new_term_ref();
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = shape[0] - 1; i >= 0; i--) {
if (!PL_put_float(head, NUMERIC_DATA(s)[i]) ||
!PL_cons_list(tail, head, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
case INTSXP: {
term_t head = PL_new_term_ref();
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = shape[0] - 1; i >= 0; i--) {
if (!PL_put_int64(head, INTEGER_DATA(s)[i]) ||
!PL_cons_list(tail, head, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
case LGLSXP: {
term_t head = PL_new_term_ref();
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = shape[0] - 1; i >= 0; i--) {
if (!PL_put_variable(head) || /* TBD: All PL_put_bool() */
!PL_unify_bool(head, LOGICAL_DATA(s)[i]) ||
!PL_cons_list(tail, head, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
case CPLXSXP: {
term_t headr = PL_new_term_ref();
term_t headi = PL_new_term_ref();
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = shape[0] - 1; i >= 0; i--) {
if (COMPLEX_DATA(s)[i].i >= 0) {
if (!PL_put_float(headr, COMPLEX_DATA(s)[i].r) ||
!PL_put_float(headi, COMPLEX_DATA(s)[i].i) ||
!PL_cons_functor(headi, FUNCTOR_i1, headi) ||
!PL_cons_functor(headr, FUNCTOR_plus2, headr, headi) ||
!PL_cons_list(tail, headr, tail))
return FALSE;
} else if (!PL_put_float(headr, COMPLEX_DATA(s)[i].r) ||
!PL_put_float(headi, -COMPLEX_DATA(s)[i].i) ||
!PL_cons_functor(headi, FUNCTOR_i1, headi) ||
!PL_cons_functor(headr, FUNCTOR_minus2, headr, headi) ||
!PL_cons_list(tail, headr, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
case VECSXP: {
SEXP names = GET_NAMES(s);
term_t av = PL_new_term_refs(2);
term_t head = PL_new_term_ref();
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = LENGTH(s) - 1; i >= 0; i--) {
SEXP elem = VECTOR_ELT(s, i);
if (names == R_NilValue || STRING_ELT(names, i) == R_NilValue) {
// PL_unify(av+0,av+1);
if (!sexp_to_pl(av, elem) ||
// !PL_cons_functor_v(head, FUNCTOR_equal2, av) ||
!PL_cons_list(tail, av, tail))
return FALSE;
} else if (!PL_put_atom_chars(av + 0, CHAR(STRING_ELT(names, i))) ||
!sexp_to_pl(av + 1, elem) ||
!PL_cons_functor_v(head, FUNCTOR_equal2, av) ||
!PL_cons_list(tail, head, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
case STRSXP: {
term_t tail = PL_new_term_ref();
PL_put_nil(tail);
for (i = shape[0] - 1; i >= 0; i--) {
const char *chars = CHAR(CHARACTER_DATA(s)[i]);
term_t head = PL_new_term_ref();
// use string to communicate with outside world
if (!PL_unify_chars(head, PL_STRING | REP_UTF8, -1, chars) ||
!PL_cons_list(tail, head, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
default: {
char buf[256];
snprintf(buf, 255, "Unsupported r-type, with id: %d \n", TYPEOF(s));
return REAL_Error(buf, t);
}
}
if (shape[0] == 1) {
if (!PL_get_arg(1, t, t)) /* Just return the head */
REAL_Error("argument access", t);
}
break;
}
case 2: {
SEXP adims = getAttrib(s, R_DimSymbol);
int nrows = INTEGER(adims)[0];
int ncols = INTEGER(adims)[1];
term_t tail = PL_new_term_ref();
term_t nest_tail = PL_new_term_ref();
term_t nest_head = PL_new_term_ref();
int i, j, c;
PL_put_nil(tail);
for (i = (nrows - 1); i > -1; i--) {
PL_put_nil(nest_tail);
for (j = (ncols - 1); j > -1; j--) {
c = (j * nrows) + i;
// { size_t index = col_i*len + row_i;
switch (TYPEOF(s)) {
case REALSXP:
if (!PL_put_float(nest_head, NUMERIC_DATA(s)[c]))
return FALSE;
break;
case INTSXP:
if (!PL_put_int64(nest_head, INTEGER_DATA(s)[c]))
return FALSE;
break;
case STRSXP:
nest_head = PL_new_term_ref();
if (!PL_unify_chars(nest_head, PL_STRING | REP_UTF8, -1,
CHAR(CHARACTER_DATA(s)[c])))
return FALSE;
break;
case LGLSXP:
if (!PL_put_variable(nest_head) ||
!PL_unify_bool(nest_head, LOGICAL_DATA(s)[c]))
return FALSE;
break;
}
if (!PL_cons_list(nest_tail, nest_head, nest_tail))
return FALSE;
}
if (!PL_cons_list(tail, nest_tail, tail))
return FALSE;
}
PL_put_term(t, tail);
break;
}
default:
assert(0);
}
return TRUE;
}
/*******************************
* START/END *
*******************************/
static foreign_t init_R(void) {
int argc = 2;
char *argv[] = {"R", "--slave", "--vanilla"};
// Rf_endEmbeddedR(0);
#if R_SIGNAL_HANDLERS
R_SignalHandlers = 0;
#endif
Rf_initEmbeddedR(argc, argv);
R_CStackLimit = -1;
return TRUE;
}
static foreign_t stop_R(void) {
Rf_endEmbeddedR(0);
R_dot_Last();
R_RunExitFinalizers();
R_gc();
return TRUE;
}
/*******************************
* EXECUTE COMMAND *
*******************************/
static SEXP process_expression(const char *expression) {
SEXP e, tmp, val;
int hadError;
ParseStatus status;
int nprotect = 0;
// PROTECT_AND_COUNT(tmp = mkString(expression));
PROTECT_AND_COUNT(tmp = ScalarString(mkCharCE(expression, CE_UTF8)));
PROTECT_AND_COUNT(e = R_ParseVector(tmp, 1, &status, R_NilValue));
if (status != PARSE_OK) {
Sdprintf("Error: %d, in parsing R expression.\n", status);
/* do not continue with protected_tryEval() */
/* PL_unify_term(except, PL_FUNCTOR_CHARS, "r_expression_syntax_error", 2,
* PL_CHARS, expression, PL_R_INTEGER, status ); */
/*FIXME: return the expression too (as atom) */
/* PL_FUNCTOR_CHARS, "r_expression_syntax_error", 2, PL_CHARS, "atom",
* PL_TERM, to; */
/* return PL_raise_exception(except); */
Ureturn NULL;
}
/* FIXME: Check status (nicos: it seems to be always 1 though? */
PROTECT_AND_COUNT(
val = protected_tryEval(VECTOR_ELT(e, 0), R_GlobalEnv, &hadError));
if (!hadError) {
Ureturn val;
}
{ Ureturn NULL; }
}
static foreign_t send_R_command(term_t cmd) {
char *s = NULL;
term_t except = PL_new_term_ref();
if (PL_get_chars(cmd, &s, CVT_ALL | REP_UTF8 | BUF_MALLOC)) {
if (process_expression(s)) {
PL_free(s);
return TRUE;
}
PL_free(s);
if (PL_unify_term(except, PL_FUNCTOR_CHARS, "real_error", 1, PL_CHARS,
"correspondence"))
return PL_raise_exception(except);
return FALSE;
}
Sdprintf("Error in PL_get_chars for %s\n", s); /* FIXME: Exception */
return FALSE;
}
// fast copy of a Prolog vector to R
static foreign_t send_c_vector(term_t tvec, term_t tout) {
char *s = NULL;
int arity, i;
atom_t name;
term_t targ = PL_new_term_ref();
SEXP rho = R_GlobalEnv, ans;
int nprotect = 0;
if (!PL_get_name_arity(tvec, &name, &arity) || arity <= 0) {
return FALSE;
}
if (!PL_get_atom_chars(tout, &s)) {
return FALSE;
}
_PL_get_arg(1, tvec, targ);
if (PL_is_number(targ)) {
int ints = TRUE;
for (i = 0; i < arity; i++) {
_PL_get_arg(i + 1, tvec, targ);
if (!PL_is_integer(targ)) {
ints = FALSE;
if (!PL_is_float(targ)) {
Ureturn FALSE;
}
}
}
if (ints) {
int *vec;
PROTECT_AND_COUNT(ans = allocVector(INTSXP, arity));
if (!ans)
return FALSE;
vec = INTEGER(ans);
for (i = 0; i < arity; i++) {
int64_t j;
_PL_get_arg(i + 1, tvec, targ);
if (!PL_get_int64(targ, &j)) {
Ureturn FALSE;
}
vec[i] = j;
}
} else {
double *vec;
PROTECT_AND_COUNT(ans = allocVector(REALSXP, arity));
if (!ans) {
Ureturn FALSE;
}
vec = REAL(ans);
for (i = 0; i < arity; i++) {
_PL_get_arg(i + 1, tvec, targ);
if (!PL_get_float(targ, vec + i)) {
int64_t j;
if (!PL_get_int64(targ, &j)) {
Ureturn FALSE;
}
vec[i] = j;
}
}
}
} else if (PL_is_atom(targ) || PL_is_string(targ)) {
PROTECT_AND_COUNT(ans = allocVector(STRSXP, arity));
if (!ans) {
Ureturn FALSE;
}
for (i = 0; i < arity; i++) {
char *str = NULL;
_PL_get_arg(i + 1, tvec, targ);
if (PL_get_chars(targ, &str, CVT_ALL | BUF_DISCARDABLE | REP_UTF8)) {
SET_STRING_ELT(ans, i, mkCharCE(str, CE_UTF8));
} else {
Ureturn FALSE;
}
}
} else {
Ureturn FALSE;
}
defineVar(install(s), ans, rho);
Ureturn TRUE;
}
static foreign_t rexpr_to_pl_term(term_t in, term_t out) {
char *s;
if (PL_get_chars(in, &s, CVT_ALL | BUF_MALLOC | REP_UTF8)) {
SEXP sexp;
if ((sexp = process_expression(s))) {
term_t tmp = PL_new_term_ref();
PL_free(s);
if (sexp_to_pl(tmp, sexp))
return PL_unify(out, tmp);
return FALSE;
} else { /* FIXME: Throw exception */
PL_free(s);
}
}
return FALSE;
}
static foreign_t robj_to_pl_term(term_t name, term_t out) {
char *plname;
int nprotect = 0;
if (PL_get_chars(name, &plname, CVT_ALL | BUF_DISCARDABLE | REP_UTF8)) {
SEXP s;
term_t tmp = PL_new_term_ref();
int rc;
PROTECT_AND_COUNT(s = findVar(install(plname), R_GlobalEnv));
if (s == R_UnboundValue || TYPEOF(s) == SYMSXP) {
Ureturn REAL_Error("r_variable", name);
}
rc = sexp_to_pl(tmp, s);
if (rc) {
Ureturn PL_unify(out, tmp);
}
}
{ Ureturn FALSE; }
}
static foreign_t set_R_variable(term_t rvar, term_t value) {
char *vname = NULL;
SEXP sexp;
int nprotect = 0;
bool rc = false;
if (PL_get_chars(rvar, &vname, CVT_ALL | BUF_MALLOC | REP_UTF8)) {
PROTECT_AND_COUNT(sexp = (term_to_sexp(value, TRUE)));
if (!Rf_isNull(sexp))
defineVar(Rf_install(vname), sexp, R_GlobalEnv);
rc = true;
}
if (vname)
PL_free(vname);
Ureturn rc;
}
static foreign_t execute_R_1(term_t value) {
SEXP sexp;
foreign_t rc = FALSE;
int nprotect = 0;
int hadError;
PROTECT_AND_COUNT(R_GlobalEnv);
PROTECT_AND_COUNT(sexp = term_to_sexp(value, TRUE));
rc = !Rf_isNull(sexp);
if (rc) {
PROTECT_AND_COUNT(sexp = protected_tryEval(sexp, R_GlobalEnv, &hadError));
if (hadError) {
Ureturn false;
}
}
Ureturn rc;
}
static foreign_t execute_R(term_t rvar, term_t value) {
SEXP sexp;
foreign_t rc = FALSE;
term_t t1 = PL_new_term_ref();
int nprotect = 0;
PROTECT_AND_COUNT(sexp = term_to_sexp(value, true));
// PROTECT_AND_COUNT( sexp = protected_tryEval(sexp, R_GlobalEnv, &hadError)
// );
if (sexp == R_UnboundValue || Rf_isNull(sexp)) {
PL_reset_term_refs(t1);
Ureturn false;
} else {
int hadError = false;
sexp = protected_tryEval(sexp, R_GlobalEnv, &hadError);
if (hadError) {
PL_reset_term_refs(t1);
Ureturn false;
}
}
if (PL_is_ground(rvar)) {
rc = bind_sexp(rvar, sexp);
} else {
if (!sexp_to_pl(t1, sexp))
rc = FALSE;
else
rc = PL_unify(rvar, t1);
}
PL_reset_term_refs(t1);
Ureturn rc;
}
static foreign_t is_R_variable(term_t t) {
SEXP name, o;
char *s;
int nprotect = 0;
/* is this variable defined in R?. */
if (PL_get_chars(t, &s, CVT_ATOM | CVT_STRING | BUF_DISCARDABLE | REP_UTF8)) {
PROTECT_AND_COUNT(name = NEW_CHARACTER(1));
CHARACTER_DATA(name)[0] = mkCharCE(s, CE_UTF8);
} else {
Ureturn FALSE;
}
PROTECT_AND_COUNT(
o = findVar(install(CHAR(STRING_ELT(name, 0))), R_GlobalEnv));
Ureturn o != R_UnboundValue;
}
#ifndef ATOM_dot
#define ATOM_dot PL_new_atom(".")
#endif
X_API install_t
install_real(void) { /* FUNCTOR_dot2 = PL_new_functor(PL_new_atom("."), 2); */
ATOM_break = PL_new_atom("break");
ATOM_false = PL_new_atom("false");
ATOM_function = PL_new_atom("function");
ATOM_i = PL_new_atom("i");
ATOM_next = PL_new_atom("next");
ATOM_true = PL_new_atom("true");
FUNCTOR_at2 = PL_new_functor(PL_new_atom("@"), 2);
FUNCTOR_boolop1 = PL_new_functor(PL_new_atom("@"), 1);
FUNCTOR_brackets1 = PL_new_functor(PL_new_atom("()"), 1);
FUNCTOR_dollar1 = PL_new_functor(PL_new_atom("$"), 1);
FUNCTOR_dollar2 = PL_new_functor(PL_new_atom("$"), 2);
FUNCTOR_dot1 = PL_new_functor(ATOM_dot, 1);
FUNCTOR_equal2 = PL_new_functor(PL_new_atom("="), 2);
FUNCTOR_hat2 = PL_new_functor(PL_new_atom("^"), 2);
FUNCTOR_i1 = PL_new_functor(ATOM_i, 1);
FUNCTOR_if2 = PL_new_functor(PL_new_atom("->"), 2);
FUNCTOR_iff2 = PL_new_functor(PL_new_atom("if"), 2);
FUNCTOR_iff3 = PL_new_functor(PL_new_atom("if"), 3);
FUNCTOR_in2 = PL_new_functor(PL_new_atom("in"), 2);
FUNCTOR_inner2 = PL_new_functor(PL_new_atom("@*@"), 2);
FUNCTOR_for3 = PL_new_functor(PL_new_atom("for"), 3);
FUNCTOR_minus1 = PL_new_functor(PL_new_atom("-"), 1);
FUNCTOR_minus2 = PL_new_functor(PL_new_atom("-"), 2);
FUNCTOR_outer2 = PL_new_functor(PL_new_atom("@^@"), 2);
FUNCTOR_plus1 = PL_new_functor(PL_new_atom("+"), 1);
FUNCTOR_plus2 = PL_new_functor(PL_new_atom("+"), 2);
FUNCTOR_quote1 = PL_new_functor(PL_new_atom("quote"), 1);
FUNCTOR_repeat1 = PL_new_functor(PL_new_atom("repeat"), 1);
FUNCTOR_square_brackets2 = PL_new_functor(PL_new_atom("[]"), 2);
FUNCTOR_tilde1 = PL_new_functor(PL_new_atom("~"), 1);
FUNCTOR_tilde2 = PL_new_functor(PL_new_atom("~"), 2);
FUNCTOR_while2 = PL_new_functor(PL_new_atom("while"), 2);
PL_register_foreign("init_R", 0, init_R, 0);
PL_register_foreign("stop_R", 0, stop_R, 0);
PL_register_foreign("send_R_command", 1, send_R_command, 0);
PL_register_foreign("send_c_vector", 2, send_c_vector, 0);
PL_register_foreign("rexpr_to_pl_term", 2, rexpr_to_pl_term, 0);
PL_register_foreign("robj_to_pl_term", 2, robj_to_pl_term, 0);
PL_register_foreign("set_R_variable", 2, set_R_variable, 0);
PL_register_foreign("execute_R", 2, execute_R, 0);
PL_register_foreign("execute_R", 1, execute_R_1, 0);
PL_register_foreign("is_R_variable", 1, is_R_variable, 0);
}
#endif /* R_H */
Reference in New Issue View Git Blame Copy Permalink