diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

yap4r

Browse Source
This commit is contained in:
Vítor Santos Costa 2019-04-02 10:27:37 +01:00
parent 9156b90b66
commit 63a514cad5
9 changed files with 143 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
packages/real/CMakeLists.txt
View File

@ -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}

56
packages/real/real.c
View File

@ -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 */
/// @}

114
packages/real/real.h
View File

@ -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);

6
packages/real/yap4r/NAMESPACE
View File

@ -1,3 +1,5 @@
useDynLib(yap4r, .registration=TRUE)
exportPattern("^[[:alpha:]]+")
importFrom(Rcpp, evalCpp)
import(Rcpp)
useDynLib(yap4r, .registration=TRUE)

19
packages/real/yap4r/R/RcppExports.R
View File

@ -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)
}

15
packages/real/yap4r/R/zzz.R Normal file
View File

@ -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)

8
packages/real/yap4r/src/Makevars.in
View File

@ -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

48
packages/real/yap4r/src/RcppExports.cpp
View File

@ -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}
};

75
packages/real/yap4r/src/yap4r.cpp
View File

@ -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")
;
}