void evaljac(int n,double* x,int ind,int* jcvar,double* jcval,int* jcnnz,
int* flag) {
int i;
double zero[1] = {0};
SEXP flag_r,jcvar_r,jcval_r,jcnnz_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("ind") ,createRIntScalar(ind) ,environment_r);
defineVar(install("jcvar") ,createRIntVector(1,NULL) ,environment_r);
defineVar(install("jcval") ,createRRealVector(1,NULL),environment_r);
EVAL(evaljac_r);
jcnnz_r = findVar(install("jcnnz"),environment_r);
jcvar_r = findVar(install("jcvar"),environment_r);
jcval_r = findVar(install("jcval"),environment_r);
flag_r = findVar(install("flag") ,environment_r);
*jcnnz = (INTEGER(AS_INTEGER(EVAL(jcnnz_r))))[0];
for (i = 0; i < *jcnnz; i++) {
jcvar[i] = (INTEGER(AS_INTEGER(EVAL(jcvar_r))))[i];
jcval[i] = (REAL(EVAL(jcval_r)))[i];
}
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
/* used in devWindows.c and cairoDevice */
void doMouseEvent(pDevDesc dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), dd->eventEnv);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, dd->eventEnv);
if (TYPEOF(handler) == CLOSXP) {
defineVar(install("which"), ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = ScalarReal( (x - dd->left) / (dd->right - dd->left) ));
PROTECT(sy = ScalarReal((y - dd->bottom) / (dd->top - dd->bottom) ));
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(5);
R_FlushConsole();
}
dd->gettingEvent = TRUE;
return;
}
/* used in devWindows.c and cairoDevice */
void doKeybd(pDevDesc dd, R_KeyName rkey,
const char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
PROTECT(handler = findVar(install(keybdHandler), dd->eventEnv));
if (TYPEOF(handler) == PROMSXP) {
handler = eval(handler, dd->eventEnv);
UNPROTECT(1); /* handler */
PROTECT(handler);
}
if (TYPEOF(handler) == CLOSXP) {
SEXP s_which = install("which");
defineVar(s_which, ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(skey = mkString(keyname ? keyname : keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(3);
R_FlushConsole();
}
UNPROTECT(1); /* handler */
dd->gettingEvent = TRUE;
return;
}
void Tptp::addTheory(Theory theory) {
ExprManager * em = getExprManager();
switch(theory) {
case THEORY_CORE:
//TPTP (CNF and FOF) is unsorted so we define this common type
{
std::string d_unsorted_name = "$$unsorted";
d_unsorted = em->mkSort(d_unsorted_name);
preemptCommand( new DeclareTypeCommand(d_unsorted_name, 0, d_unsorted) );
}
// propositionnal
defineType("Bool", em->booleanType());
defineVar("$true", em->mkConst(true));
defineVar("$false", em->mkConst(false));
addOperator(kind::AND);
addOperator(kind::EQUAL);
addOperator(kind::IMPLIES);
//addOperator(kind::ITE); //only for tff thf
addOperator(kind::NOT);
addOperator(kind::OR);
addOperator(kind::XOR);
addOperator(kind::APPLY_UF);
//Add quantifiers?
break;
default:
std::stringstream ss;
ss << "internal error: Tptp::addTheory(): unhandled theory " << theory;
throw ParserException(ss.str());
}
}
void evalh(int n,double* x,int* hlin,int* hcol,double* hval,int* hnnz,
int* flag) {
int i;
double zero[1] = {0};
SEXP hlin_r,hcol_r,hval_r,hnnz_r,flag_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("hlin"),createRIntVector(1,NULL) ,environment_r);
defineVar(install("hcol"),createRIntVector(1,NULL) ,environment_r);
defineVar(install("hval"),createRRealVector(1,NULL),environment_r);
EVAL(evalh_r);
hnnz_r = findVar(install("hnnz"),environment_r);
flag_r = findVar(install("flag"),environment_r);
hlin_r = findVar(install("hlin"),environment_r);
hcol_r = findVar(install("hcol"),environment_r);
hval_r = findVar(install("hval"),environment_r);
*hnnz = (INTEGER(AS_INTEGER(EVAL(hnnz_r))))[0];
for (i = 0; i < *hnnz; i++) {
hlin[i] = (INTEGER(AS_INTEGER(EVAL(hlin_r))))[i];
hcol[i] = (INTEGER(AS_INTEGER(EVAL(hcol_r))))[i];
hval[i] = (REAL(EVAL(hval_r)))[i];
}
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
void evalfc(int n,double* x,double* f,int m,double* constr,
int* flag) {
int i;
SEXP flag_r,constr_r,f_r;
defineVar(install("n"),createRIntScalar(n) ,environment_r);
defineVar(install("x"),createRRealVector(n,x) ,environment_r);
defineVar(install("m"),createRIntScalar(m) ,environment_r);
defineVar(install("constr"),createRRealVector(1,NULL),environment_r);
EVAL(evalfc_r);
f_r = findVar(install("f") ,environment_r);
constr_r = findVar(install("constr"),environment_r);
flag_r = findVar(install("flag"),environment_r);
*f = (REAL(EVAL(f_r)))[0];
for (i = 0; i < m; i++) {
constr[i] = (REAL(EVAL(constr_r)))[i];
}
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
void evalhlp(int n,double *x,int m,double *lambda,double sf,
double *sc,double *p,double *hp,int *gothl,int *flag) {
int i;
SEXP hp_r,gothl_r,flag_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("m") ,createRIntScalar(m) ,environment_r);
defineVar(install("lambda"),createRRealVector(m,lambda),environment_r);
defineVar(install("sf") ,createRRealScalar(sf) ,environment_r);
defineVar(install("sc") ,createRRealVector(m,sc) ,environment_r);
defineVar(install("p") ,createRRealVector(n,p) ,environment_r);
defineVar(install("hp") ,createRRealVector(n,hp) ,environment_r);
defineVar(install("gothl") ,createRIntScalar(*gothl) ,environment_r);
EVAL(evalhlp_r);
hp_r = findVar(install("hp") ,environment_r);
gothl_r = findVar(install("gothl") ,environment_r);
flag_r = findVar(install("flag") ,environment_r);
for (i = 0; i < n; i++)
hp[i] = (REAL(EVAL(hp_r)))[i];
*gothl = (INTEGER(AS_INTEGER(EVAL(gothl_r))))[0];
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
void endp (int n,double* x,double* l,double* u,int m,double* lambda,
int* equatn, int* linear) {
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("l") ,createRRealVector(n,l) ,environment_r);
defineVar(install("u") ,createRRealVector(n,u) ,environment_r);
defineVar(install("m") ,createRIntScalar(m) ,environment_r);
defineVar(install("lambda"),createRRealVector(m,lambda),environment_r);
defineVar(install("equatn"),createRIntVector(m,equatn) ,environment_r);
defineVar(install("linear"),createRIntVector(m,linear) ,environment_r);
EVAL(endp_r);
free(x);
free(l);
free(u);
free(lambda);
free(equatn);
free(linear);
x = NULL;
l = NULL;
u = NULL;
lambda = NULL;
equatn = NULL;
linear = NULL;
}
void evalf(int n,double* x,double* f,int* flag) {
SEXP flag_r,f_r;
defineVar(install("n"),createRIntScalar(n) ,environment_r);
defineVar(install("x"),createRRealVector(n,x),environment_r);
EVAL(evalf_r);
f_r = findVar(install("f"), environment_r);
flag_r = findVar(install("flag"),environment_r);
*f = (REAL(EVAL(f_r)))[0];
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
int i, n = LENGTH(d);
SEXP xpt;
double *b = (double *) NULL, *g = (double *) NULL,
*h = (double *) NULL, fx = R_PosInf;
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if (!isEnvironment(rho))
error(_("'rho' must be an environment"));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if (hs != R_NilValue && gr == R_NilValue)
error(_("When Hessian defined must also have gradient defined"));
if (R_NilValue == (xpt = findVarInFrame(rho, install(".par"))) ||
!isReal(xpt) || LENGTH(xpt) != n)
error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
n);
/* We are going to alter .par, so must duplicate it */
defineVar(install(".par"), duplicate(xpt), rho);
PROTECT(xpt = findVarInFrame(rho, install(".par")));
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl=REAL(lowerb), *ru=REAL(upperb);
b = Calloc(2*n, double);
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lower' and 'upper' must be numeric vectors"));
SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv;
checkArity(op, args);
if (!isString(CAR(args)) || length(CAR(args)) == 0)
error(_("invalid first argument"));
else
name = installTrChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
expr = CAR(args);
args = CDR(args);
eenv = CAR(args);
if (isNull(eenv)) {
error(_("use of NULL environment is defunct"));
eenv = R_BaseEnv;
} else
if (!isEnvironment(eenv))
errorcall(call, _("invalid '%s' argument"), "eval.env");
args = CDR(args);
aenv = CAR(args);
if (isNull(aenv)) {
error(_("use of NULL environment is defunct"));
aenv = R_BaseEnv;
} else
if (!isEnvironment(aenv))
errorcall(call, _("invalid '%s' argument"), "assign.env");
defineVar(name, mkPROMISE(expr, eenv), aenv);
return R_NilValue;
}
/* makeLazy(names, values, expr, eenv, aenv) */
SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP names, values, val, expr, eenv, aenv, expr0;
R_xlen_t i;
checkArity(op, args);
names = CAR(args); args = CDR(args);
if (!isString(names))
error(_("invalid first argument"));
values = CAR(args); args = CDR(args);
expr = CAR(args); args = CDR(args);
eenv = CAR(args); args = CDR(args);
if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env");
aenv = CAR(args);
if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env");
for(i = 0; i < XLENGTH(names); i++) {
SEXP name = installChar(STRING_ELT(names, i));
PROTECT(val = eval(VECTOR_ELT(values, i), eenv));
PROTECT(expr0 = duplicate(expr));
SETCAR(CDR(expr0), val);
defineVar(name, mkPROMISE(expr0, eenv), aenv);
UNPROTECT(2);
}
return R_NilValue;
}
Expr
Parser::mkBoundVar(const std::string& name, const Type& type) {
Debug("parser") << "mkVar(" << name << ", " << type << ")" << std::endl;
Expr expr = d_exprManager->mkBoundVar(name, type);
defineVar(name, expr, false);
return expr;
}
Expr
Parser::mkVar(const std::string& name, const Type& type, uint32_t flags) {
Debug("parser") << "mkVar(" << name << ", " << type << ")" << std::endl;
Expr expr = d_exprManager->mkVar(name, type, flags);
defineVar(name, expr, flags & ExprManager::VAR_FLAG_GLOBAL);
return expr;
}
void R_RegisterCCallable(const char *package, const char *name, DL_FUNC fptr)
{
SEXP penv = get_package_CEntry_table(package);
SEXP eptr = R_MakeExternalPtrFn(fptr, R_NilValue, R_NilValue);
PROTECT(eptr);
defineVar(install(name), eptr, penv);
UNPROTECT(1);
}
void evalc(int n,double* x,int ind,double* cind,int* flag) {
SEXP flag_r,cind_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x),environment_r);
defineVar(install("ind"),createRIntScalar(ind) ,environment_r);
EVAL(evalc_r);
cind_r = findVar(install("cind"),environment_r);
flag_r = findVar(install("flag"),environment_r);
*cind = (REAL(EVAL(cind_r)))[0];
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
SEXP xts_period_apply(SEXP _data, SEXP _index, SEXP _function, SEXP _env)
{
if (!isInteger(_index)) {
error("index must be integer");
}
int i;
R_xlen_t n = xlength(_index);
SEXP _result = PROTECT(allocVector(VECSXP, n));
SEXP _j = PROTECT(allocVector(INTSXP, ncols(_data)));
SEXP _drop = PROTECT(ScalarLogical(0));
int *index = INTEGER(_index);
for (i = 0; i < ncols(_data); i++)
INTEGER(_j)[i] = i + 1;
SEXP _idx0 = PROTECT(ScalarInteger(0));
SEXP _idx1 = PROTECT(ScalarInteger(0));
int *idx0 = INTEGER(_idx0);
int *idx1 = INTEGER(_idx1);
/* reprotect the subset object */
SEXP _xsubset;
PROTECT_INDEX px;
PROTECT_WITH_INDEX(_xsubset = R_NilValue, &px);
/* subset object name */
SEXP _subsym = install("_.*crazy*._.*name*._");
defineVar(_subsym, _xsubset, _env);
/* function call on subset */
SEXP _subcall = PROTECT(lang3(_function, _subsym, R_DotsSymbol));
int N = n - 1;
for (i = 0; i < N; i++) {
idx0[0] = index[i] + 1;
idx1[0] = index[i + 1];
REPROTECT(_xsubset = extract_col(_data, _j, _drop, _idx0, _idx1), px);
defineVar(_subsym, _xsubset, _env);
SET_VECTOR_ELT(_result, i, eval(_subcall, _env));
}
UNPROTECT(7);
return _result;
}
void evalg(int n,double* x,double* g,int* flag) {
int i;
SEXP flag_r,g_r;
defineVar(install("n"),createRIntScalar(n) ,environment_r);
defineVar(install("x"),createRRealVector(n,x) ,environment_r);
defineVar(install("g"),createRRealVector(n,NULL),environment_r);
EVAL(evalg_r);
g_r = findVar(install("g"), environment_r);
flag_r = findVar(install("flag"),environment_r);
for (i = 0; i < n; i++)
g[i] = (REAL(EVAL(g_r)))[i];
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
SEXP ralgencan(SEXP evalf_ptr,SEXP evalg_ptr,SEXP evalh_ptr,
SEXP evalc_ptr,SEXP evaljac_ptr,SEXP evalhc_ptr,SEXP evalfc_ptr,
SEXP evalgjac_ptr, SEXP evalgjacp_ptr, SEXP evalhl_ptr,
SEXP evalhlp_ptr,SEXP inip_ptr, SEXP endp_ptr,SEXP param_ptr,
SEXP environment_ptr) {
int checkder,inform,iprint,m,n,ncomp;
double cnorm,f,nlpsupn,efacc,eoacc,epsfeas,epsopt,snorm;
int coded[11];
int *equatn,*linear;
double *l,*lambda,*u,*x;
SEXP return_value;
evalf_r = evalf_ptr;
evalg_r = evalg_ptr;
evalh_r = evalh_ptr;
evalc_r = evalc_ptr;
evaljac_r = evaljac_ptr;
evalhc_r = evalhc_ptr;
evalfc_r = evalfc_ptr;
evalgjac_r = evalgjac_ptr;
evalgjacp_r = evalgjacp_ptr;
evalhl_r = evalhl_ptr;
evalhlp_r = evalhlp_ptr;
inip_r = inip_ptr;
endp_r = endp_ptr;
param_r = param_ptr;
environment_r = environment_ptr;
/* SET SOME SOLVER ARGUMENTS */
param(&epsfeas,&epsopt,&efacc,&eoacc,&iprint,&ncomp);
/* SET UP PROBLEM DATA */
inip(&n,&x,&l,&u,&m,&lambda,&equatn,&linear,coded,&checkder);
C2FLOGICALV(equatn,m);
C2FLOGICALV(linear,m);
C2FLOGICALV(coded,11);
Algencan(epsfeas,epsopt,efacc,eoacc,iprint,ncomp,n,x,l,u,m,lambda,
equatn,linear,coded,checkder,f,cnorm,snorm,nlpsupn,inform);
/* WRITE ADDITIONAL OUTPUT INFORMATION CODED BY THE USER */
endp(n,x,l,u,m,lambda,equatn,linear);
defineVar(install("AlgencanReturnValue"),createRIntScalar(0),
environment_r);
defineVar(install("f"),createRRealScalar(f),environment_r);
defineVar(install("cnorm"),createRRealScalar(cnorm),environment_r);
defineVar(install("snorm"),createRRealScalar(snorm),environment_r);
defineVar(install("nlpsupn"),createRRealScalar(nlpsupn),environment_r);
defineVar(install("inform"),createRIntScalar(inform),environment_r);
return_value = findVar(install("AlgencanReturnValue"),environment_r);
return return_value;
}
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass;
int i, j, n;
Rboolean matched = FALSE;
/* if X is a list, recurse. Otherwise if it matches classes call f */
if(isNewList(X)) {
n = length(X);
if (replace) {
PROTECT(ans = shallow_duplicate(X));
} else {
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
}
for(i = 0; i < n; i++)
SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
deflt, replace, rho));
UNPROTECT(1);
return ans;
}
if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
matched = TRUE;
else {
PROTECT(klass = R_data_class(X, FALSE));
for(i = 0; i < LENGTH(klass); i++)
for(j = 0; j < length(classes); j++)
if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
matched = TRUE;
UNPROTECT(1);
}
if(matched) {
/* This stores value to which the function is to be applied in
a variable X in the environment of the rapply closure call
that calls into the rapply .Internal. */
SEXP R_fcall; /* could allocate once and preserve for re-use */
SEXP Xsym = install("X");
defineVar(Xsym, X, rho);
INCREMENT_NAMED(X);
/* PROTECT(R_fcall = lang2(FUN, Xsym)); */
PROTECT(R_fcall = lang3(FUN, Xsym, R_DotsSymbol));
ans = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(ans))
ans = lazy_duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return lazy_duplicate(X);
else return lazy_duplicate(deflt);
}
void set_BLACS_APTS_in_R(){
/* Define R objects. */
SEXP R_apts;
/* Protect R objects. */
PROTECT(R_apts = R_MakeExternalPtr(&BLACS_APTS, R_NilValue, R_NilValue));
/* Assign an R object in ".GlobalEnv". */
defineVar(install(BLACS_APTS_R_NAME), R_apts, R_GlobalEnv);
/* These are only saw by new pakcages. */
BLACS_APTS.BI_MaxNCtxt = &BI_MaxNCtxt;
BLACS_APTS.BI_MaxNSysCtxt = &BI_MaxNSysCtxt;
BLACS_APTS.BI_Iam = &BI_Iam;
BLACS_APTS.BI_Np = &BI_Np;
BLACS_APTS.BI_ReadyB = BI_ReadyB;
BLACS_APTS.BI_ActiveQ = BI_ActiveQ;
BLACS_APTS.BI_AuxBuff = &BI_AuxBuff;
BLACS_APTS.BI_MyContxts = BI_MyContxts;
BLACS_APTS.BI_SysContxts = BI_SysContxts;
BLACS_APTS.BI_COMM_WORLD = BI_COMM_WORLD;
BLACS_APTS.BI_Stats = BI_Stats;
#if (BLACS_APTS_DEBUG & 1) == 1
int myrank;
MPI_Comm_rank(MPI_COMM_WORLD, &myrank);
if(myrank == 0){
REprintf(" %s (v): %d %d %d %d %d.\n", __FILE__, BI_MaxNCtxt,
BI_MaxNSysCtxt, BI_Iam, BI_Np, BI_AuxBuff);
/* Not a good idea to print NULL pointers.
REprintf(" %s (v): %d %d %d %d.\n", __FILE__, *BI_ReadyB,
*BI_ActiveQ, **BI_MyContxts, *BI_COMM_WORLD);
REprintf(" %s (v): %d %d.\n", __FILE__, *BI_SysContxts,
*BI_Stats);
*/
REprintf(" %s (v): %d %d %d.\n", __FILE__, BI_AuxBuff.Len,
BI_AuxBuff.nAops, BI_AuxBuff.N);
REprintf(" %s (a): %x %x %x %x %x.\n", __FILE__, &BI_MaxNCtxt,
&BI_MaxNSysCtxt, &BI_Iam, &BI_Np, &BI_AuxBuff);
REprintf(" %s (a): %x %x %x %x.\n", __FILE__, BI_ReadyB,
BI_ActiveQ, *BI_MyContxts, BI_COMM_WORLD);
REprintf(" %s (a): %x %x.\n", __FILE__, BI_SysContxts,
BI_Stats);
}
#endif
/* Unprotect R objects. */
UNPROTECT(1);
} /* End of set_BLACS_APTS_in_R(). */
SEXP lapply(SEXP list, SEXP expr, SEXP rho)
{
int i, n = length(list);
SEXP ans;
if(!isNewList(list)) error("`list' must be a list");
if(!isEnvironment(rho)) error("`rho' should be an environment");
PROTECT(ans = allocVector(VECSXP, n));
for(i = 0; i < n; i++) {
defineVar(install("x"), VECTOR_ELT(list, i), rho);
SET_VECTOR_ELT(ans, i, eval(expr, rho));
}
setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
UNPROTECT(1);
return(ans);
}
static SEXP get_package_CEntry_table(const char *package)
{
SEXP penv, pname;
if (CEntryTable == NULL) {
CEntryTable = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
R_PreserveObject(CEntryTable);
}
pname = install(package);
penv = findVarInFrame(CEntryTable, pname);
if (penv == R_UnboundValue) {
penv = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
defineVar(pname, penv, CEntryTable);
}
return penv;
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises.
FUN must be unevaluated for use in e.g. bquote .
*/
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
PROTECT_INDEX px;
checkArity(op, args);
SEXP X, XX, FUN;
PROTECT_WITH_INDEX(X =CAR(args), &px);
XX = PROTECT(eval(CAR(args), rho));
R_xlen_t n = xlength(XX); // a vector, so will be valid.
FUN = CADR(args);
Rboolean realIndx = n > INT_MAX;
SEXP ans = PROTECT(allocVector(VECSXP, n));
SEXP names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP isym = install("i");
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
SEXP R_fcall = PROTECT(LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
for(R_xlen_t i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
tmp = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(6);
return ans;
}
void evalhl(int n,double *x,int m,double *lambda,double sf,
double *sc,int *hllin,int *hlcol,double *hlval,int *hlnnz,
int *flag) {
int i;
SEXP hlnnz_r,hlcol_r,hllin_r,hlval_r,flag_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("m") ,createRIntScalar(m) ,environment_r);
defineVar(install("lambda"),createRRealVector(m,lambda),environment_r);
defineVar(install("sf") ,createRRealScalar(sf) ,environment_r);
defineVar(install("sc") ,createRRealVector(m,sc) ,environment_r);
defineVar(install("hllin") ,createRIntVector(1,NULL) ,environment_r);
defineVar(install("hlcol") ,createRIntVector(1,NULL) ,environment_r);
defineVar(install("hlval") ,createRRealVector(1,NULL) ,environment_r);
EVAL(evalhl_r);
hlnnz_r = findVar(install("hlnnz"),environment_r);
hllin_r = findVar(install("hllin"),environment_r);
hlcol_r = findVar(install("hlcol"),environment_r);
hlval_r = findVar(install("hlval"),environment_r);
flag_r = findVar(install("flag") ,environment_r);
*hlnnz = (INTEGER(AS_INTEGER(EVAL(hlnnz_r))))[0];
for (i = 0; i < *hlnnz; i++){
hllin[i] = (INTEGER(AS_INTEGER(EVAL(hllin_r))))[i];
hlcol[i] = (INTEGER(AS_INTEGER(EVAL(hlcol_r))))[i];
hlval[i] = (REAL(EVAL(hlval_r)))[i];
}
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
void evalgjac(int n,double *x,double *g,int m,int *jcfun,int *jcvar,
double *jcval,int *jcnnz,int *flag) {
int i;
SEXP g_r,jcfun_r,jcvar_r,jcval_r,jcnnz_r,flag_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("g") ,createRRealVector(n,x) ,environment_r);
defineVar(install("m") ,createRIntScalar(m) ,environment_r);
defineVar(install("jcfun"),createRIntVector(1,NULL) ,environment_r);
defineVar(install("jcvar"),createRIntVector(1,NULL) ,environment_r);
defineVar(install("jcval"),createRRealVector(1,NULL),environment_r);
defineVar(install("jcnnz"),createRIntScalar(0) ,environment_r);
EVAL(evalgjac_r);
g_r = findVar(install("g") ,environment_r);
jcnnz_r = findVar(install("jcnnz"),environment_r);
jcfun_r = findVar(install("jcfun"),environment_r);
jcvar_r = findVar(install("jcvar"),environment_r);
jcval_r = findVar(install("jcval"),environment_r);
flag_r = findVar(install("flag") ,environment_r);
*jcnnz = (INTEGER(AS_INTEGER(EVAL(jcnnz_r))))[0];
for (i = 0; i < n; i++)
g[i] = (REAL(EVAL(g_r)))[i];
for (i = 0; i < *jcnnz; i++) {
jcfun[i] = (INTEGER(AS_INTEGER(EVAL(jcfun_r))))[i];
jcvar[i] = (INTEGER(AS_INTEGER(EVAL(jcvar_r))))[i];;
jcval[i] = (REAL(EVAL(jcval_r)))[i];;
}
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
SEXP _IntAEAE_toEnvir(const IntAEAE *aeae, SEXP envir, int keyshift)
{
int nelt, i;
const IntAE *ae;
char key[11];
SEXP value;
nelt = _IntAEAE_get_nelt(aeae);
for (i = 0; i < nelt; i++) {
ae = aeae->elts[i];
if (_IntAE_get_nelt(ae) == 0)
continue;
//snprintf(key, sizeof(key), "%d", i + keyshift);
snprintf(key, sizeof(key), "%010d", i + keyshift);
PROTECT(value = _new_INTEGER_from_IntAE(ae));
defineVar(install(key), value, envir);
UNPROTECT(1);
}
return envir;
}
void muste_set_R_string(char *dest,char *sour) // RS 25.11.2012
{
SEXP tmp;
char *hakuapu,*teksti;
char tyhja[]="";
if (dest==NULL) return;
if (sour==NULL) teksti=tyhja;
else teksti=sour;
hakuapu=strchr(dest,'$')+1;
if (hakuapu==NULL) hakuapu=dest;
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar(teksti));
defineVar(install(hakuapu),tmp,muste_environment);
UNPROTECT(1); // tmp
// snprintf(cmd,LLENGTH,"%s<-\"%s\"",dest,sour);
// muste_evalr(cmd);
}
zorba::StatelessExternalFunction *
RExternalModule::getExternalFunction(zorba::String name) const
{
SEXP val;
zorba::StatelessExternalFunction *ans = NULL;
const char * const str = name.c_str();
val = findVar(Rf_install(str), env); /* findVarInFrame3(env, Rf_install(str), (Rboolean) TRUE) for just this frame. */
if(val == R_UnboundValue) {
// raise an exception with our own class.
// throw ExternalFunctionData::createZorbaException
fprintf(stderr, "Can't find %s in module\n", str);
return(NULL);
// throw zorba::DynamicException();
}
if(TYPEOF(val) == PROMSXP)
val = Rf_eval(val, R_GlobalEnv);
if(TYPEOF(val) == CLOSXP) {
zorba::ItemFactory *itemFactory;
RXQueryFunction *func;
SEXP rval;
zorba::simplestore::SimpleStore* lStore = zorba::simplestore::SimpleStoreManager::getStore();
zorba::Zorba *zorba = zorba::Zorba::getInstance(lStore);
itemFactory = zorba->getItemFactory();
func = new RXQueryClosureFunction(str, itemFactory, val, true);
PROTECT(rval = makeExternalRObject(func, "RClosureExternalFunction"));
defineVar(Rf_install(str), rval, getEnvironment());
UNPROTECT(1);
ans = dynamic_cast<zorba::PureStatelessExternalFunction*>(func);
} else {
ans = R_GET_REF(val, zorba::StatelessExternalFunction);
}
return(ans);
}
SEXP InstanceObjectTable::assign(const char * name, SEXP value) {
checkInstance();
SEXP sym = R_NilValue;
Property *prop = _instance->klass()->property(name);
if (prop) {
bool writable = prop->isWritable();
if (writable) {
prop->write(_instance->sexp(), value);
sym = install(name);
}
delete prop;
if (!writable)
error("Property '%s' is read-only", name);
}
if (sym == R_NilValue) {
if (_internal) {
sym = install(name);
defineVar(sym, value, fieldEnv());
} else error("No such property '%s'", name);
}
return sym;
}
