yap4r
This commit is contained in:
Vítor Santos Costa
parent
9156b90b66
commit
63a514cad5
|
|
@ -1,6 +1,15 @@
|
|||
|
||||
# PROJECT ( YAP_REAL C )
|
||||
|
||||
set(YAP4R_SOURCES
|
||||
yap4r/man/yap4r-package.Rd
|
||||
yap4r/R/zzz.R
|
||||
yap4r/NAMESPACE
|
||||
yap4r/DESCRIPTION
|
||||
yap4r/src/yap4r.cpp
|
||||
yap4r/src/RcppExports.cpp
|
||||
)
|
||||
|
||||
set(REAL_SOURCES real.c)
|
||||
|
||||
# LIBR_FOUND
|
||||
|
|
@ -16,10 +25,10 @@ set_package_properties(R PROPERTIES
|
|||
URL "https://www.r-project.org/")
|
||||
|
||||
|
||||
foreach(f ${FILES})
|
||||
foreach(f ${YAP4R_SOURCES})
|
||||
add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f}
|
||||
COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_SOURCE_DIR}/${f} ${CMAKE_CURRENT_BINARY_DIR}/${f}
|
||||
DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${f}
|
||||
DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${f}
|
||||
)
|
||||
list(APPEND OUTS ${CMAKE_CURRENT_BINARY_DIR}/${f} )
|
||||
endforeach()
|
||||
|
|
@ -28,12 +37,14 @@ add_custom_target(YAP4R
|
|||
WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}
|
||||
DEPENDS ${OUTS}
|
||||
)
|
||||
|
||||
add_library(real ${REAL_SOURCES})
|
||||
target_link_libraries (real ${LIBR_LIBRARIES} libYap)
|
||||
include_directories (
|
||||
${CMAKE_CURRENT_BINARY_DIR}
|
||||
${CMAKE_BINARY_DIR}
|
||||
${CMAKE_SOURCE_DIR}/include
|
||||
${CMAKE_CURRENT_SOURCE_DIR}
|
||||
${LIBR_INCLUDE_DIRS}
|
||||
)
|
||||
|
||||
|
|
@ -51,21 +62,8 @@ include_directories (
|
|||
configure_file ("yap4r/src/Makevars.in" "yap4r/src/Makevars" )
|
||||
|
||||
|
||||
set(YAP4R_SOURCES
|
||||
yap4r/man/yap4r-package.Rd
|
||||
yap4r/R
|
||||
yap4r/R/RcppExports.R
|
||||
yap4r/NAMESPACE
|
||||
yap4r/DESCRIPTION
|
||||
yap4r/src
|
||||
yap4r/src/Makevars.in
|
||||
yap4r/src/yap4r.cpp
|
||||
yap4r/src/RcppExports.cpp
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
add_dependencies(real YAP4R)
|
||||
|
||||
install(TARGETS real
|
||||
RUNTIME DESTINATION ${YAP_INSTALL_LIBDIR}
|
||||
ARCHIVE DESTINATION ${YAP_INSTALL_LIBDIR}
|
||||
|
|
|
|||
|
|
@ -16,59 +16,24 @@
|
|||
*/
|
||||
#define CSTACK_DEFNS
|
||||
#include "rconfig.h"
|
||||
#if HAVE_R_H || !defined(_YAP_NOT_INSTALLED_)
|
||||
|
||||
#include <SWI-Prolog.h>
|
||||
#undef ERROR
|
||||
#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 <R.h>
|
||||
|
||||
#include <Rdefines.h>
|
||||
#include <assert.h>
|
||||
#include <string.h>
|
||||
#include <R_ext/Parse.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;
|
||||
}
|
||||
#include "real.h"
|
||||
|
||||
static atom_t ATOM_break;
|
||||
static atom_t ATOM_false;
|
||||
|
|
@ -106,9 +71,6 @@ 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 */
|
||||
|
|
@ -491,7 +453,7 @@ static int merge_dots(term_t t) {
|
|||
}
|
||||
|
||||
// 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) {
|
||||
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: {
|
||||
|
|
@ -1226,7 +1188,7 @@ static int pl_to_binary(const char *s, term_t t, term_t tmp, SEXP *ansP) {
|
|||
*
|
||||
* @return whether it succeeds or fails.
|
||||
*/
|
||||
static SEXP(term_to_sexp(term_t t, bool eval)) {
|
||||
SEXP term_to_sexp(term_t t, bool eval) {
|
||||
int nprotect = 0;
|
||||
SEXP ans = R_NilValue;
|
||||
int objtype;
|
||||
|
|
@ -1671,8 +1633,7 @@ static int bind_sexp(term_t t, SEXP sexp) {
|
|||
/*******************************
|
||||
* SEXP --> Prolog *
|
||||
*******************************/
|
||||
|
||||
static int sexp_to_pl(term_t t, SEXP s) {
|
||||
bool sexp_to_pl(term_t t, SEXP s) {
|
||||
int rank = sexp_rank(s);
|
||||
size_t shape[256];
|
||||
|
||||
|
|
@ -2225,6 +2186,5 @@ install_real(void) { /* FUNCTOR_dot2 = PL_new_functor(PL_new_atom("."), 2); */
|
|||
PL_register_foreign("is_R_variable", 1, is_R_variable, 0);
|
||||
}
|
||||
|
||||
#endif /* R_H */
|
||||
/// @}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,68 +1,64 @@
|
|||
#include <Rembedded.h>
|
||||
#include <R.h>
|
||||
#include <Rinternals.h>
|
||||
#include <Rdefines.h>
|
||||
#include <R_ext/Parse.h>
|
||||
|
||||
/**
|
||||
* @file real.h
|
||||
* @date Sat May 19 13:44:04 2018
|
||||
*
|
||||
* @brief Prolog to R interface
|
||||
*
|
||||
*
|
||||
*/
|
||||
|
||||
#include <YapInterface.h>
|
||||
#include <c_interface.h>
|
||||
#ifdef __cplusplus
|
||||
extern "C"{
|
||||
#endif
|
||||
|
||||
bool R_isNull(SEXP sexp);
|
||||
|
||||
#define BUFSIZE 256
|
||||
#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
|
||||
|
||||
typedef unsigned int PL_Type;
|
||||
// #define PL_free(v)
|
||||
|
||||
#define PL_Nil 0
|
||||
#define PL_Var 1
|
||||
#define PL_Atom 2
|
||||
#define PL_Appl 3
|
||||
#define PL_Pair 4
|
||||
#define PL_Int 5
|
||||
#define PL_Float 6
|
||||
#define PL_DbRef 7
|
||||
#define PL_Unknown 8
|
||||
static inline SEXP protected_tryEval(SEXP expr, SEXP env, int *errp) {
|
||||
SEXP o;
|
||||
o = R_tryEval(expr, env, errp);
|
||||
return o ? o : expr;
|
||||
}
|
||||
|
||||
|
||||
#ifndef term_t
|
||||
#define term_t YAP_Int
|
||||
#endif
|
||||
|
||||
typedef enum {
|
||||
r_undefined,
|
||||
r_double,
|
||||
r_int,
|
||||
r_character
|
||||
} r_basic_types;
|
||||
|
||||
extern bool sexp_to_pl(term_t t, SEXP s);
|
||||
extern SEXP term_to_sexp(term_t t, bool eval);
|
||||
|
||||
typedef struct
|
||||
{
|
||||
r_basic_types type;
|
||||
union {
|
||||
int int_val;
|
||||
double double_val;
|
||||
char *char_val;
|
||||
} real_u;
|
||||
} list_cell;
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
int size;
|
||||
int nDims;
|
||||
int dims[BUFSIZE];
|
||||
list_cell values[BUFSIZE];
|
||||
} list;
|
||||
|
||||
#define real_Int 1
|
||||
#define real_Float 2
|
||||
#define real_Char 3
|
||||
#define real_Bool 4
|
||||
|
||||
#define real_ty_Vector 1
|
||||
#define real_ty_Matrix 2
|
||||
#define real_ty_List 3
|
||||
#define real_ty_Array 4 //not used, yet
|
||||
|
||||
extern void init_R(void);
|
||||
extern void end_R(void);
|
||||
extern void send_command(char * expression);
|
||||
extern int set_list_values(void);
|
||||
extern int set_vec_values(void);
|
||||
extern int set_array_values(void);
|
||||
extern SEXP process_expression(char * expression);
|
||||
extern YAP_Term sexp_pl(SEXP s);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
useDynLib(yap4r, .registration=TRUE)
|
||||
exportPattern("^[[:alpha:]]+")
|
||||
importFrom(Rcpp, evalCpp)
|
||||
import(Rcpp)
|
||||
useDynLib(yap4r, .registration=TRUE)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,19 +0,0 @@
|
|||
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
||||
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
||||
|
||||
query <- function(p_name, p_module, sexp) {
|
||||
.Call(`_yap4r_query`, p_name, p_module, sexp)
|
||||
}
|
||||
|
||||
next <- function() {
|
||||
.Call(`_yap4r_next`)
|
||||
}
|
||||
|
||||
cut <- function() {
|
||||
.Call(`_yap4r_cut`)
|
||||
}
|
||||
|
||||
ask <- function(i) {
|
||||
.Call(`_yap4r_ask`, i)
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
|
||||
## Up until R 2.15.0, the require("methods") is needed but (now)
|
||||
## triggers an warning from R CMD check
|
||||
#.onLoad <- function(libname, pkgname){
|
||||
# #require("methods") ## needed with R <= 2.15.0
|
||||
# loadRcppModules()
|
||||
#}
|
||||
|
||||
|
||||
## For R 2.15.1 and later this also works. Note that calling loadModule() triggers
|
||||
## a load action, so this does not have to be placed in .onLoad() or evalqOnLoad().
|
||||
loadModule("mod_yap4r", TRUE)
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,2 +1,6 @@
|
|||
PKG_LIBS=-L${YAP_LIBDIR} -L${YAP_DLLDIR} -L ../../.. -lreal -lYap
|
||||
PKG_CPPFLAGS=-I${YAP_SOURCE_DIR}/CXX -I${YAP_BINARY_DIR} -I${YAP_SOURCE_DIR}/include -I${YAP_SOURCE_DIR}/H -I${YAP_SOURCE_DIR}/OPTYap -I${YAP_SOURCE_DIR}/os -I../..
|
||||
PKG_LIBS=-Wl,-rpath=${YAP_LIBDIR} -Wl,-rpath=${YAP_DLLDIR} \
|
||||
-L${YAP_LIBDIR} -L${YAP_DLLDIR} -lreal -lYAP++ -lYap
|
||||
PKG_CXXFLAGS=-I${YAP_SOURCE_DIR}/CXX -I${YAP_BINARY_DIR}\
|
||||
-I${YAP_SOURCE_DIR}/include -I${YAP_SOURCE_DIR}/H\
|
||||
-I${YAP_SOURCE_DIR}/OPTYap -I${YAP_SOURCE_DIR}/os\
|
||||
-I../.. -I${YAP_SOURCE_DIR}/utf8proc -I${YAP_SOURCE_DIR}/packages/real
|
||||
|
|
|
|||
|
|
@ -5,58 +5,10 @@
|
|||
|
||||
using namespace Rcpp;
|
||||
|
||||
// query
|
||||
bool query(std::string p_name, std::string p_module, SEXP sexp);
|
||||
RcppExport SEXP _yap4r_query(SEXP p_nameSEXP, SEXP p_moduleSEXP, SEXP sexpSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< std::string >::type p_name(p_nameSEXP);
|
||||
Rcpp::traits::input_parameter< std::string >::type p_module(p_moduleSEXP);
|
||||
Rcpp::traits::input_parameter< SEXP >::type sexp(sexpSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(query(p_name, p_module, sexp));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// next
|
||||
bool next();
|
||||
RcppExport SEXP _yap4r_next() {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = Rcpp::wrap(next());
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// cut
|
||||
bool cut();
|
||||
RcppExport SEXP _yap4r_cut() {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = Rcpp::wrap(cut());
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// ask
|
||||
SEXP ask(int i);
|
||||
RcppExport SEXP _yap4r_ask(SEXP iSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< int >::type i(iSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(ask(i));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
|
||||
RcppExport SEXP _rcpp_module_boot_mod_yap4r();
|
||||
|
||||
static const R_CallMethodDef CallEntries[] = {
|
||||
{"_yap4r_query", (DL_FUNC) &_yap4r_query, 3},
|
||||
{"_yap4r_next", (DL_FUNC) &_yap4r_next, 0},
|
||||
{"_yap4r_cut", (DL_FUNC) &_yap4r_cut, 0},
|
||||
{"_yap4r_ask", (DL_FUNC) &_yap4r_ask, 1},
|
||||
{"_rcpp_module_boot_mod_yap4r", (DL_FUNC) &_rcpp_module_boot_mod_yap4r, 0},
|
||||
{NULL, NULL, 0}
|
||||
};
|
||||
|
|
|
|||
|
|
@ -6,13 +6,14 @@
|
|||
#include <yapi.hh>
|
||||
|
||||
#include <vector>
|
||||
#include <string>
|
||||
|
||||
#include "real.h"
|
||||
|
||||
|
||||
using namespace Rcpp;
|
||||
|
||||
class YAP4R {
|
||||
class yap4r {
|
||||
|
||||
YAPEngine *yap;
|
||||
YAPQuery *q;
|
||||
|
|
@ -20,74 +21,78 @@ class YAP4R {
|
|||
bool failed;
|
||||
|
||||
public:
|
||||
//[[Rcpp::export]]
|
||||
yap4r();
|
||||
bool query(std::string p_name,std::string p_module,Rcpp::GenericVector sexps);
|
||||
bool more();
|
||||
bool done();
|
||||
SEXP peek(int i);
|
||||
};
|
||||
|
||||
YAP4R() {
|
||||
yap4r::yap4r() {
|
||||
YAPEngineArgs *yargs = new YAPEngineArgs();
|
||||
yap = new YAPEngine(yargs);
|
||||
};
|
||||
|
||||
|
||||
//[[Rcpp::export]]
|
||||
bool query(std::string p_name,std::string p_module, SEXP sexp) {
|
||||
|
||||
|
||||
bool yap4r::query(std::string p_name,std::string p_module,Rcpp::GenericVector sexps) {
|
||||
|
||||
YAPPairTerm tmp;
|
||||
if (q) {
|
||||
q->close();
|
||||
q = NULL;
|
||||
}
|
||||
if (!sexp_to_pl(tmp.handle(), sexp))
|
||||
return false;
|
||||
args = tmp.listToVector();
|
||||
YAPTerm ts[1], hd;
|
||||
std::vector<Term> args = std::vector<Term>();
|
||||
yhandle_t sls = Yap_NewHandles(sexps.length());
|
||||
for (int i=0; i<sexps.length();i++) {
|
||||
if (!sexp_to_pl(sls+i, sexps[i]))
|
||||
return false;
|
||||
args.push_back( Yap_GetFromSlot(sls+i) );
|
||||
}
|
||||
YAPTerm qt = YAPApplTerm(p_name,args);
|
||||
q = new YAPQuery(qt);
|
||||
return true;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
//[[Rcpp::export]]
|
||||
bool next() {
|
||||
|
||||
bool yap4r::more() {
|
||||
bool rc = true;
|
||||
if (failed)
|
||||
return false;
|
||||
if (q)
|
||||
rc = next();
|
||||
rc = q->next();
|
||||
if (!rc) {
|
||||
failed = true;
|
||||
}
|
||||
return rc;
|
||||
}
|
||||
|
||||
//[[Rcpp::export]]
|
||||
bool cut() {
|
||||
bool rc = true;
|
||||
|
||||
bool yap4r::done() {
|
||||
|
||||
if (failed)
|
||||
return false;
|
||||
if (q)
|
||||
rc = cut();
|
||||
q->cut();
|
||||
q = NULL;
|
||||
return rc;
|
||||
};
|
||||
return true;
|
||||
}
|
||||
|
||||
//[[Rcpp::export]]
|
||||
SEXP ask(int i) {
|
||||
|
||||
SEXP yap4r::peek(int i) {
|
||||
if (failed || q==nullptr)
|
||||
return R_MissingArg;
|
||||
return term_to_sexp(YAPTerm(Yap_XREGS[i]).handle(), false);
|
||||
};
|
||||
return term_to_sexp(Yap_InitSlot(Yap_XREGS[i]), false);
|
||||
}
|
||||
|
||||
|
||||
|
||||
};
|
||||
|
||||
RCPP_MODULE(mod_yap4r) {
|
||||
Rcpp::class_<YAP4R>( "YAP4R" )
|
||||
.constructor("documentation for default constructor")
|
||||
.method( "query", &YAP4R::query )
|
||||
.method( "next", &YAP4R::next )
|
||||
.method( "ask", &YAP4R::ask )
|
||||
.method( "cut", &YAP4R::cut )
|
||||
;
|
||||
;
|
||||
class_<yap4r>( "yap4r" )
|
||||
.constructor("create an object encapsulating a Prolog engine")
|
||||
.method( "query", &yap4r::query, "create an active query within the engine")
|
||||
.method( "more", &yap4r::more, "ask for an extra solution")
|
||||
.method( "done", &yap4r::done, "terminate the query")
|
||||
.method( "peek", &yap4r::peek, "load arg[i] into R")
|
||||
;
|
||||
}
|
||||
|
|
|
|||
Reference in New Issue