static SCM
expand_letstar (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
return expand_letstar_clause (CADR (expr), CDDR (expr), env);
}
/* vector(mode="logical", length=0) */
SEXP attribute_hidden do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
{
R_xlen_t len;
SEXP s;
SEXPTYPE mode;
checkArity(op, args);
if (length(CADR(args)) != 1) error(_("invalid '%s' argument"), "length");
len = asVecSize(CADR(args));
if (len < 0) error(_("invalid '%s' argument"), "length");
s = coerceVector(CAR(args), STRSXP);
if (length(s) != 1) error(_("invalid '%s' argument"), "mode");
mode = str2type(CHAR(STRING_ELT(s, 0))); /* ASCII */
if (mode == -1 && streql(CHAR(STRING_ELT(s, 0)), "double"))
mode = REALSXP;
switch (mode) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case EXPRSXP:
case VECSXP:
case RAWSXP:
s = allocVector(mode, len);
break;
case LISTSXP:
if (len > INT_MAX) error("too long for a pairlist");
s = allocList((int) len);
break;
default:
error(_("vector: cannot make a vector of mode '%s'."),
translateChar(STRING_ELT(s, 0))); /* should be ASCII */
}
if (mode == INTSXP || mode == LGLSXP)
Memzero(INTEGER(s), len);
else if (mode == REALSXP)
Memzero(REAL(s), len);
else if (mode == CPLXSXP)
Memzero(COMPLEX(s), len);
else if (mode == RAWSXP)
Memzero(RAW(s), len);
/* other cases: list/expression have "NULL", ok */
return s;
}
struct lispobj *eval_let(struct lispobj *exps, struct lispobj *env)
{
struct lispobj *binds, *body, *vars, *vals, *lambda, *ret, *evals;
binds = CAR(exps);
body = CDR(exps);
if(length(binds) > 0) {
struct lispobj *tvars, *tvals;
vars = heap_grab(NEW_CONS(NULL, NULL));
vals = heap_grab(NEW_CONS(NULL, NULL));
tvars = vars; tvals = vals;
while(binds != NULL) {
struct lispobj *bind = CAR(binds);
if(length(bind) != 2) {
ret = NEW_ERROR("Bad binding in the let exp.\n");
goto exit;
}
CAR(tvars) = heap_grab(CAR(bind));
CAR(tvals) = heap_grab(CADR(bind));
CDR(tvars) = heap_grab(NEW_CONS(NULL, NULL));
CDR(tvals) = heap_grab(NEW_CONS(NULL, NULL));
tvars = CDR(tvars);
tvals = CDR(tvals);
binds = CDR(binds);
}
tvars = NULL;
tvals = NULL;
} else {
return NEW_ERROR("Empty bindgings in the let exp.\n");
}
lambda = heap_grab(env_proc_make(vars, body, env));
evals = heap_grab(env_val_list(vals, env));
if(evals != NULL && OBJ_TYPE(evals) == ERROR) {
ret = evals;
} else {
ret = apply(lambda, evals);
heap_release(evals);
}
heap_release(lambda);
exit:
heap_release(vals);
heap_release(vars);
return ret;
}
/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP in = CAR(args), out = CADR(args);
SET_ATTRIB(out, ATTRIB(in));
IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
SET_OBJECT(out, OBJECT(in));
return out;
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names, X, XX, FUN;
R_xlen_t i, n;
PROTECT_INDEX px;
checkArity(op, args);
PROTECT_WITH_INDEX(X = CAR(args), &px);
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* 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 */
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
tmp = eval(R_fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(3);
}
UNPROTECT(3); /* X, XX, ans */
return ans;
}
SEXP attribute_hidden complex_math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
R_xlen_t i, n, na, nb;
Rcomplex ai, bi, *a, *b, *y;
SEXP sa, sb, sy;
Rboolean naflag = FALSE;
cm2_fun f;
switch (PRIMVAL(op)) {
case 0: /* atan2 */
f = z_atan2; break;
case 10001: /* round */
f = z_rround; break;
case 2: /* passed from do_log1arg */
case 10:
case 10003: /* passed from do_log */
f = z_logbase; break;
case 10004: /* signif */
f = z_prec; break;
default:
errorcall_return(call, _("unimplemented complex function"));
}
PROTECT(sa = coerceVector(CAR(args), CPLXSXP));
PROTECT(sb = coerceVector(CADR(args), CPLXSXP));
na = XLENGTH(sa); nb = XLENGTH(sb);
if ((na == 0) || (nb == 0)) {
UNPROTECT(2);
return(allocVector(CPLXSXP, 0));
}
n = (na < nb) ? nb : na;
PROTECT(sy = allocVector(CPLXSXP, n));
a = COMPLEX(sa); b = COMPLEX(sb); y = COMPLEX(sy);
for (i = 0; i < n; i++) {
ai = a[i % na]; bi = b[i % nb];
if(ISNA(ai.r) && ISNA(ai.i) &&
ISNA(bi.r) && ISNA(bi.i)) {
y[i].r = NA_REAL; y[i].i = NA_REAL;
} else {
f(&y[i], &ai, &bi);
if ( (ISNAN(y[i].r) || ISNAN(y[i].i)) &&
!(ISNAN(ai.r) || ISNAN(ai.i) || ISNAN(bi.r) || ISNAN(bi.i)) )
naflag = TRUE;
}
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
if(n == na) {
DUPLICATE_ATTRIB(sy, sa);
} else if(n == nb) {
DUPLICATE_ATTRIB(sy, sb);
}
UNPROTECT(3);
return sy;
}
static void fcn(int n, const double x[], double *f, function_info
*state)
{
SEXP s, R_fcall;
ftable *Ftable;
double *g = (double *) 0, *h = (double *) 0;
int i;
R_fcall = state->R_fcall;
Ftable = state->Ftable;
if ((i = FT_lookup(n, x, state)) >= 0) {
*f = Ftable[i].fval;
return;
}
/* calculate for a new value of x */
s = CADR(R_fcall);
for (i = 0; i < n; i++) {
if (!R_FINITE(x[i])) error(_("non-finite value supplied by 'nlm'"));
REAL(s)[i] = x[i];
}
s = PROTECT(eval(state->R_fcall, state->R_env));
switch(TYPEOF(s)) {
case INTSXP:
if (length(s) != 1) goto badvalue;
if (INTEGER(s)[0] == NA_INTEGER) {
warning(_("NA replaced by maximum positive value"));
*f = DBL_MAX;
}
else *f = INTEGER(s)[0];
break;
case REALSXP:
if (length(s) != 1) goto badvalue;
if (!R_FINITE(REAL(s)[0])) {
warning(_("NA/Inf replaced by maximum positive value"));
*f = DBL_MAX;
}
else *f = REAL(s)[0];
break;
default:
goto badvalue;
}
if (state->have_gradient) {
g = REAL(PROTECT(coerceVector(getAttrib(s, install("gradient")), REALSXP)));
if (state->have_hessian) {
h = REAL(PROTECT(coerceVector(getAttrib(s, install("hessian")), REALSXP)));
}
}
FT_store(n, *f, x, g, h, state);
UNPROTECT(1 + state->have_gradient + state->have_hessian);
return;
badvalue:
error(_("invalid function value in 'nlm' optimizer"));
}
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP s = CAR(args), ncopy = CADR(args);
R_xlen_t nc;
SEXP a;
if (!isVector(ncopy))
error(_("incorrect type for second argument"));
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate an object of type '%s'"),
type2char(TYPEOF(s)));
nc = xlength(ncopy); // might be 0
if (nc == xlength(s))
PROTECT(a = rep2(s, ncopy));
else {
if (nc != 1) error(_("invalid '%s' value"), "times");
#ifdef LONG_VECTOR_SUPPORT
double snc = asReal(ncopy);
if (!R_FINITE(snc) || snc < 0)
error(_("invalid '%s' value"), "times");
nc = (R_xlen_t) snc;
#else
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid '%s' value"), "times");
#endif
R_xlen_t ns = xlength(s);
PROTECT(a = rep3(s, ns, nc * ns));
}
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
SEXP RTcl_AssignObjToVar(SEXP args)
{
const void *vmax = vmaxget();
Tcl_SetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
(Tcl_Obj *) R_ExternalPtrAddr(CADDR(args)),
0);
vmaxset(vmax);
return R_NilValue;
}
int prnfunc(Obj a, Obj stream, int how){
char n;
if( NNULLP( CADR(a))){
if( how) return prn_func_macr(a, stream, "closure");
else writestr(stream, "#<closure>");
}else{
if( how) return prn_func_macr(a, stream, "lambda");
else writestr(stream, "#<lambda>");
}
return 1;
}
/* && || */
SEXP attribute_hidden do_logic2(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* && and || */
SEXP s1, s2;
int x1, x2;
SEXP ans;
if (length(args) != 2)
error(_("'%s' operator requires 2 arguments"),
PRIMVAL(op) == 1 ? "&&" : "||");
s1 = CAR(args);
s2 = CADR(args);
PROTECT(ans = allocVector(LGLSXP, 1));
s1 = eval(s1, env);
if (!isNumber(s1))
errorcall(call, _("invalid 'x' type in 'x %s y'"),
PRIMVAL(op) == 1 ? "&&" : "||");
x1 = asLogical(s1);
#define get_2nd \
s2 = eval(s2, env); \
if (!isNumber(s2)) \
errorcall(call, _("invalid 'y' type in 'x %s y'"), \
PRIMVAL(op) == 1 ? "&&" : "||"); \
x2 = asLogical(s2);
switch (PRIMVAL(op)) {
case 1: /* && */
if (x1 == FALSE)
LOGICAL(ans)[0] = FALSE;
else {
get_2nd;
if (x1 == NA_LOGICAL)
LOGICAL(ans)[0] = (x2 == NA_LOGICAL || x2) ? NA_LOGICAL : x2;
else /* x1 == TRUE */
LOGICAL(ans)[0] = x2;
}
break;
case 2: /* || */
if (x1 == TRUE)
LOGICAL(ans)[0] = TRUE;
else {
get_2nd;
if (x1 == NA_LOGICAL)
LOGICAL(ans)[0] = (x2 == NA_LOGICAL || !x2) ? NA_LOGICAL : x2;
else /* x1 == FALSE */
LOGICAL(ans)[0] = x2;
}
}
UNPROTECT(1);
return ans;
}
Obj transformSugarDef(Obj expr) {
Obj funcArgs = CADR(expr);
Obj func = CAR(funcArgs);
Obj args = CDR(funcArgs);
Obj body = CDDR(expr);
Obj lambdaExpr = CONS(LAMBDAOBJ, CONS(args, body));
Obj transformed = CONS(DEFOBJ, CONS(func, CONS(lambdaExpr, NULLOBJ)));
return transformed;
}
SEXP attribute_hidden do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, el;
R_xlen_t i, len;
int start, stop, k, l;
size_t slen;
cetype_t ienc;
const char *ss;
char *buf;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("extracting substrings from a non-character object"));
len = XLENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
for (i = 0; i < len; i++) {
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
el = STRING_ELT(x,i);
if (el == NA_STRING || start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss); /* FIXME -- should handle embedded nuls */
buf = R_AllocStringBuffer(slen+1, &cbuff);
if (start < 1) start = 1;
if (start > stop || start > slen) {
buf[0] = '\0';
} else {
if (stop > slen) stop = (int) slen;
substr(buf, ss, ienc, start, stop);
}
SET_STRING_ELT(s, i, mkCharCE(buf, ienc));
}
R_FreeStringBufferL(&cbuff);
}
DUPLICATE_ATTRIB(s, x);
/* This copied the class, if any */
UNPROTECT(1);
return s;
}
SEXP attribute_hidden do_mvfft(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP z, d;
int i, inv, maxf, maxp, n, p;
double *work;
int *iwork;
checkArity(op, args);
z = CAR(args);
d = getAttrib(z, R_DimSymbol);
if (d == R_NilValue || length(d) > 2)
error(_("vector-valued (multivariate) series required"));
n = INTEGER(d)[0];
p = INTEGER(d)[1];
switch(TYPEOF(z)) {
case INTSXP:
case LGLSXP:
case REALSXP:
z = coerceVector(z, CPLXSXP);
break;
case CPLXSXP:
if (NAMED(z)) z = duplicate(z);
break;
default:
error(_("non-numeric argument"));
}
PROTECT(z);
/* -2 for forward transform, complex values */
/* +2 for backward transform, complex values */
inv = asLogical(CADR(args));
if (inv == NA_INTEGER || inv == 0) inv = -2;
else inv = 2;
if (n > 1) {
fft_factor(n, &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
work = (double*)R_alloc(4 * maxf, sizeof(double));
iwork = (int*)R_alloc(maxp, sizeof(int));
for (i = 0; i < p; i++) {
fft_factor(n, &maxf, &maxp);
fft_work(&(COMPLEX(z)[i*n].r), &(COMPLEX(z)[i*n].i),
1, n, 1, inv, work, iwork);
}
}
UNPROTECT(1);
return z;
}
SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, ans;
checkArity(op, args);
check1arg(args, call, "x");
x = CAR(args);
if (PRIMVAL(op)) { /* xlength<- */
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
return xlengthgets(x, len);
}
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
if (len < 0) error(_("invalid value"));
if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
return xlengthgets(x, len);
#else
error(_("vector size specified is too large"));
return x; /* -Wall */
#endif
}
return lengthgets(x, (R_len_t) len);
}
SEXP setWinProgressBar(SEXP call, SEXP op, SEXP args, SEXP env)
{
args = CDR(args);
SEXP ptr = CAR(args);
winprogressbar *pbar;
double value;
pbar = R_ExternalPtrAddr(ptr);
if(!pbar)
error("invalid progressbar -- has it been closed?");
value = pbar->val;
if(!isNull(CADR(args))) {
int iv;
double val = asReal(CADR(args));
SEXP title = CADDR(args), label = CADDDR(args);
if (R_FINITE(val) && val >= pbar->min && val <= pbar->max) {
iv = pbar->width * (val - pbar->min)/(pbar->max - pbar->min);
setprogressbar(pbar->pb, iv);
pbar->val = val;
}
if (!isNull(title)) {
SEXP ctxt;
if(!isString(title) || length(title) < 1)
errorcall(call, "invalid '%s' argument", "title");
ctxt = STRING_ELT(title, 0);
if (ctxt != NA_STRING)
settext(pbar->wprog, translateChar(ctxt));
}
if(pbar->lab && !isNull(label)) {
SEXP clab;
if(!isString(label) || length(label) < 1)
errorcall(call, "invalid '%s' argument", "label");
clab = STRING_ELT(label, 0);
if (clab != NA_STRING)
settext(pbar->lab, translateChar(clab));
}
}
return ScalarReal(value);
}
/* internal API - takes one mandatory argument (object to inspect) and
two optional arguments (deep and pvec - see above), positional argument
matching only */
SEXP attribute_hidden do_inspect(SEXP call, SEXP op, SEXP args, SEXP env) {
SEXP obj = CAR(args);
int deep = -1;
int pvec = 5;
if (CDR(args) != R_NilValue) {
deep = asInteger(CADR(args));
if (CDDR(args) != R_NilValue)
pvec = asInteger(CADDR(args));
}
inspect_tree(0, CAR(args), deep, pvec);
return obj;
}
struct lispobj *subr_cons(struct lispobj *args)
{
if(length(args) != 2)
return ERROR_ARGS;
struct lispobj *car, *cdr, *pair;
car = CAR(args);
cdr = CADR(args);
pair = NEW_CONS(car, cdr);
return pair;
}
void StrPtrSBreezeProcedureList (FILE * stream, PtrProcedureList procedures, bool onlyPrintLocals, Scope scopes, char *separator, bool longForm)
{
while (procedures && (!onlyPrintLocals || CAR (procedures)->nature != ContextMarkerProcedure))
{
if ((int) CAR (procedures)->scope & (int) scopes)
{
StrPtrSBreezeProcedure (stream, CAR (procedures), longForm);
if (CDR (procedures) && (onlyPrintLocals ? CADR (procedures)->nature != ContextMarkerProcedure : true))
fprintf (stream, "%s", separator);
}
procedures = CDR (procedures);
}
}
static SCM
expand_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
return CONDITIONAL (scm_source_properties (expr),
expand (CADR (expr), env),
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
: VOID (SCM_BOOL_F)));
}
void print(struct lispobj *obj)
{
#ifdef __DEBUG_PRINT__
printf("[");
#endif /* __DEBUG_PRINT__ */
if(obj == NULL) {
printf("NIL");
} else if(OBJ_TYPE(obj) == ERROR) {
printf("Error: %s", ERROR_VALUE(obj));
} else if(OBJ_TYPE(obj) == SYMBOL) {
printf("%s", SYMBOL_VALUE(obj));
} else if(OBJ_TYPE(obj) == NUMBER) {
printf("%d", NUMBER_VALUE(obj));
} else if(OBJ_TYPE(obj) == STRING) {
printf("\"%s\"", STRING_VALUE(obj));
} else {
if(CAR(obj) == NEW_SYMBOL("PROC")) {
printf("<procedure ");
if(CADR(obj) != NEW_SYMBOL("NIL")) {
print_list(CADR(obj));
} else {
printf("()");
}
printf(" %p>", CADDDR(obj));
} else if(CAR(obj) == NEW_SYMBOL("SUBR")) {
printf("<primitive-procedure %p>", CADR(obj));
} else {
print_list(obj);
}
}
#ifdef __DEBUG_PRINT__
if(obj != NULL) {
printf(" => %d]", OBJ_REFS(obj));
} else {
printf(" => nil]");
}
#endif /* __DEBUG_PRINT__ */
return;
}
static SEXP AddParens(SEXP expr)
{
SEXP e;
if (TYPEOF(expr) == LANGSXP) {
e = CDR(expr);
while(e != R_NilValue) {
SETCAR(e, AddParens(CAR(e)));
e = CDR(e);
}
}
if (isPlusForm(expr)) {
if (isPlusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isMinusForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isTimesForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isDivideForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isPowerForm(expr)) {
if (isPowerForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
return expr;
}
SEXP RTcl_ObjFromRawVector(SEXP args)
{
int count;
Tcl_Obj *tclobj;
SEXP val;
val = CADR(args);
count = length(val);
tclobj = Tcl_NewByteArrayObj(RAW(val), count);
return makeRTclObject(tclobj);
}
SEXP RTcl_ObjFromVar(SEXP args)
{
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
tclobj = Tcl_GetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
0);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
static struct exp *fn_vector_ref(struct exp *args) {
err_ensure(exp_list_length(args) == 2,
"vector-ref requires exactly two arguments, got", args);
struct exp *vector = CAR(args);
struct exp *k = CADR(args);
err_ensure(IS(vector, VECTOR),
"vector-ref requires a vector argument, got", vector);
err_ensure(IS(k, FIXNUM),
"vector-ref requires a numeric index, got", k);
size_t i = k->value.fixnum;
err_ensure(i >= 0 && i < vector_length(vector->value.vector),
"vector-ref requires a valid index, got", k);
return vector_get(vector->value.vector, i);
}
static SCM
expand_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (expand (CAR (binding), env), fluids);
vals = scm_cons (expand (CADR (binding), env), vals);
}
return DYNLET (scm_source_properties (expr),
scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
expand_sequence (CDDR (expr), env));
}
SEXP mrb4R_is_Rvector(SEXP args) {
SEXP obj,ans;
mrb_value rbobj;
//int i,n;
obj=CADR(args);
PROTECT(ans=allocVector(LGLSXP,1));
if (!inherits(obj, "rbObj")) {
LOGICAL(ans)[0]=FALSE;
UNPROTECT(1);
return ans;
}
rbobj=*((mrb_value*) R_ExternalPtrAddr(CADR(obj)));
if(!rbIsRVector(rbobj)) {
LOGICAL(ans)[0]=FALSE;
UNPROTECT(1);
return ans;
}
LOGICAL(ans)[0]=TRUE;
UNPROTECT(1);
return ans;
}
static struct exp *fn_make_vector(struct exp *args) {
size_t len = exp_list_length(args);
err_ensure(len == 1 || len == 2,
"make-vector requires exactly one or two arguments, got", args);
struct exp *k = CAR(args);
err_ensure(k->type == FIXNUM,
"make-vector requires a numeric argument, got", k);
struct exp *fill = len == 2 ? CADR(args) : NIL;
struct exp *v = exp_make_vector(0);
size_t i;
for (i = 0; i < k->value.fixnum; i += 1) {
vector_push(v->value.vector, fill);
}
return v;
}
SEXP readRegistry(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
HKEY hive, hkey;
LONG res;
const wchar_t *key;
int maxdepth, view;
REGSAM acc = KEY_READ;
args = CDR(args);
if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("invalid '%s' value"), "key");
key = filenameToWchar(STRING_ELT(CAR(args), 0), 0);
if(!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
error(_("invalid '%s' value"), "hive");
maxdepth = asInteger(CADDR(args));
if(maxdepth == NA_INTEGER || maxdepth < 1)
error(_("invalid '%s' value"), "maxdepth");
hive = find_hive(CHAR(STRING_ELT(CADR(args), 0)));
view = asInteger(CADDDR(args));
/* Or KEY_READ with KEY_WOW64_64KEY or KEY_WOW64_32KEY to
explicitly access the 64- or 32- bit registry view. See
http://msdn.microsoft.com/en-us/library/aa384129(VS.85).aspx
*/
if(view == 2) acc |= KEY_WOW64_32KEY;
else if(view == 3) acc |= KEY_WOW64_64KEY;
res = RegOpenKeyExW(hive, key, 0, acc, &hkey);
if (res == ERROR_FILE_NOT_FOUND)
error(_("Registry key '%ls' not found"), key);
if (res != ERROR_SUCCESS)
error("RegOpenKeyEx error code %d: '%s'", (int) res, formatError(res));
ans = readRegistryKey(hkey, maxdepth, view);
RegCloseKey(hkey);
return ans;
}
SEXP jr_func(void* p)
{
ParseStatus status;
SEXP s, t, ext;
s = t = PROTECT(R_ParseVector(
Rf_mkString("function(...) {.External(\".RCall\", NULL, ...)}"),
-1, &status, R_NilValue));
ext = PROTECT(R_MakeExternalPtr(p, R_NilValue, R_NilValue));
SETCADDR(CADR(CADDR(VECTOR_ELT(t ,0))), ext);
int errorOccurred = 0;
SEXP ret;
ret = PROTECT(R_tryEval(VECTOR_ELT(s,0), R_GlobalEnv, &errorOccurred));
UNPROTECT(3);
return ret;
}
