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.
yap-6.3/packages/real/real.c

2396 lines
57 KiB
C
Raw Blame History

#include "rconfig.h"
#include <SWI-Prolog.h>
#if HAVE_R_H || !defined(_YAP_NOT_INSTALLED_)
#if HAVE_REMBEDDED_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 <Rdefines.h>
#include <R_ext/Parse.h>
#include <assert.h>
#include <string.h>
bool R_isNull(SEXP sexp);
#if 1 // DEBUG_MEMORY
#define PROTECT_AND_COUNT(EXP) { PROTECT(EXP); nprotect++; printf("%d +%d\n",+ __LINE__,nprotect); }
#define Ureturn printf("%d -%d\n", __LINE__,nprotect); unprotect(nprotect); return
#else
#define PROTECT_AND_COUNT(EXP) { PROTECT(EXP); nprotect++; }
#define Ureturn unprotect(nprotect); return
#endif
static inline SEXP
protected_tryEval( SEXP expr, SEXP env, int *errp)
{
SEXP 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;
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);
UNPROTECT(nprotect);
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;
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) ) {
strncat( so, ns, 1024-strlen(so)-1);
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( c_R = allocList(arity+1) );
call_R = c_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);
return R_NilValue;
}
if ( PL_is_functor(a, FUNCTOR_equal2) ) {
char *s;
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;
UNPROTECT( nprotect );
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(c_R = call_R = allocList(len+2));
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);
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(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;
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;
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);
}
UNPROTECT(nprotect);
return 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);
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() */
UNPROTECT(nprotect);
/* 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); */
return NULL;
}
/* FIXME: Check status (nicos: it seems to be always 1 though? */
val = protected_tryEval(VECTOR_ELT(e, 0), R_GlobalEnv, &hadError);
UNPROTECT(nprotect);
if ( !hadError )
return val;
return 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;
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;
_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;
if ( PL_get_chars(name, &plname, CVT_ALL|BUF_DISCARDABLE|REP_UTF8) )
{ SEXP s;
int nprotect = 0;
term_t tmp = PL_new_term_ref();
int rc;
PROTECT_AND_COUNT( s= findVar(install(plname), R_GlobalEnv) );
nprotect ++;
if (s == R_UnboundValue ||
TYPEOF(s)==SYMSXP)
return REAL_Error("r_variable", name);
rc = sexp_to_pl(tmp, s);
UNPROTECT(nprotect);
if ( rc )
return PL_unify(out, tmp);
}
return 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);
UNPROTECT( nprotect );
return 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) {
sexp = protected_tryEval(sexp, R_GlobalEnv, &hadError);
if (hadError)
{
UNPROTECT( nprotect );
return false;
}
} UNPROTECT( nprotect );
return 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(R_GlobalEnv);
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))
{
UNPROTECT( nprotect );
return false;
} else {
int hadError;
sexp = protected_tryEval(sexp, R_GlobalEnv, &hadError);
if (hadError)
{
UNPROTECT( nprotect );
return 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 );
}
UNPROTECT( nprotect );
return 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 {
UNPROTECT(nprotect);
return FALSE;
}
PROTECT_AND_COUNT(o = findVar(install(CHAR(STRING_ELT(name, 0))), R_GlobalEnv));
UNPROTECT(nprotect);
return o != R_UnboundValue;
}
#ifndef ATOM_dot
#define ATOM_dot PL_new_atom(".")
#endif
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