struct lispobj *eval(struct lispobj *obj, struct lispobj *env)
{
struct lispobj *ret;
if(obj == NULL || OBJ_TYPE(obj) == NUMBER ||
OBJ_TYPE(obj) == ERROR || OBJ_TYPE(obj) == STRING) {
/* Return self-evaluating object. */
ret = heap_grab(obj);
} else if(OBJ_TYPE(obj) == SYMBOL) {
/* Lookup value of the variable in the env. */
struct lispobj *val;
val = env_var_lookup(obj, env);
if(OBJ_TYPE(val) == ERROR) {
ret = heap_grab(val);
} else {
ret = heap_grab(CDR(val));
}
} else if(NEW_SYMBOL("QUOTE") == CAR(obj)) {
/* (quote whatever) */
if(length(obj) != 2) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Return quoted object. */
ret = heap_grab(CADR(obj));
}
#ifdef __DEBUG_GC__
printf("eval quote debug:");
heap_debug_object(ret);
printf("\n");
#endif
} else if(NEW_SYMBOL("SETQ") == CAR(obj)) {
/* (setq var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to assign existing variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_assign(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("LABEL") == CAR(obj)) {
/* (label var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to define new variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_define(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("IF") == CAR(obj)) {
/* (if predicate consequence alternative) */
if(length(obj) != 4) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Invoke condition function. */
struct lispobj *pred;
pred = eval(CADR(obj), env);
if(pred != NULL && OBJ_TYPE(pred) == ERROR) {
ret = pred;
} else {
if(pred) {
/* Eval consequence. */
ret = eval(CADDR(obj), env);
} else {
/* Eval alternative. */
ret = eval(CADDDR(obj), env);
}
heap_release(pred);
}
}
} else if(NEW_SYMBOL("COND") == CAR(obj)) {
/* (cond (cond1 ret1) (cond2 ret2)) */
if(length(obj) < 2) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_cond(CDR(obj), env);
}
}
else if(NEW_SYMBOL("LET") == CAR(obj)) {
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_let(CDR(obj), env);
}
} else if(NEW_SYMBOL("PROGN") == CAR(obj)) {
ret = eval_progn(CDR(obj), env);
} else if(NEW_SYMBOL("LAMBDA") == CAR(obj)) {
/* (lambda (var) (proc var var)) */
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Make and return new procedure. */
ret = heap_grab(env_proc_make(CADR(obj), CDDR(obj), env));
}
} else {
/* Apply case. */
struct lispobj *proc = eval(CAR(obj), env);
if(proc != NULL && OBJ_TYPE(proc) == ERROR) {
ret = proc;
} else {
struct lispobj *args = heap_grab(env_val_list(CDR(obj), env));
if(args != NULL && OBJ_TYPE(args) == ERROR) {
ret = args;
} else {
ret = apply(proc, args);
heap_release(args);
}
heap_release(proc);
}
}
return ret;
}
Obj assVal(Obj expr) { return CADDR(expr); }
uptr_t exec_special(uptr_t *env, uptr_t form) {
uptr_t fn = CAR(form);
uptr_t args = CDR(form);
switch(SVAL(fn)) {
case S_LET:
return let(env, args);
case S_FN:
return form;
case S_LOOP:
return loop(env, args);
case S_DO: {
uptr_t *body_p = refer(args), rval = NIL;
while (*body_p) {
rval = eval(env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(1); // body_p
return rval;
}
case S_RECUR: {
uptr_t rval, *fn_p = refer(fn);
rval = build_cons(*fn_p, eval_list(env, args));
release(1); // fn_p
return rval;
}
case S_QUOTE:
return CAR(args);
case S_CAR:
return CAR(eval(env, CAR(args)));
case S_CDR:
return CDR(eval(env, CAR(args)));
case S_AND: {
if (IS_NIL(args)) return PS_TRUE;
uptr_t *rem_args = refer(args),
rval = NIL;
while ((rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
release(1);
return rval;
}
case S_OR: {
if (IS_NIL(args)) return NIL;
uptr_t *rem_args = refer(args),
rval = NIL;
while (!(rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
release(1);
return rval;
}
case S_NOT: {
if (IS_NIL(args)) return NIL;
uptr_t rval = eval(env, CAR(args));
return rval ? NIL : PS_TRUE;
}
case S_IF: {
uptr_t rval = NIL, *clauses = refer(args);
if (eval(env, CAR(*clauses)) && CDR(*clauses))
rval = eval(env, CADR(*clauses));
else if (CDDR(*clauses))
rval = eval(env, CADDR(*clauses));
release(1); // clauses
return rval;
}
case S_WHEN: {
uptr_t rval = NIL, *cond_p = refer(CAR(args)), *body_p = refer(CDR(args));
if (eval(env, *cond_p))
while(*body_p) {
rval = eval(env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(2); // cond_p, body_p
return rval;
}
case S_CONS: {
uptr_t rval = NIL, *args_p = refer(args);
rval = build_cons(eval(env, CAR(*args_p)), eval(env, CADR(*args_p)));
release(1); // args_p
return rval;
}
case S_PRINT:
print_form(eval(env, CAR(args)));
printf_P(PSTR("\n"));
return NIL;
case S_DEF: {
uptr_t *args_p = refer(args),
*binding = refer(eval(env, CADR(args)));
assoc(env, CAR(*args_p), *binding);
release(2); // args_p, binding
return *binding; // Yeah, it's been "released", but the pointer is still valid.
}
case S_EVAL:
return eval(env, eval(env, CAR(args)));
#define _COMPR(rval) { \
if (IS_NIL(args)) return NIL; \
\
uptr_t *args_p = refer(args); \
while(CDR(*args_p) && (eval(env, CAR(*args_p)) _COMP_OPR eval(env, CADR(*args_p)))) \
*args_p = CDR(*args_p); \
\
if (IS_NIL(CDR(*args_p))) \
rval = eval(env, CAR(*args_p)); \
release(1); \
}
#define _COMP_OPR ==
case S_EQL: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
case S_NEQL: {
uptr_t rval = NIL;
_COMPR(rval);
return rval ? NIL : PS_TRUE;
}
#undef _COMP_OPR
#define _COMP_OPR <
case S_LT: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR <=
case S_LTE: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR >
case S_GT: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR >=
case S_GTE: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _ARITH(coll) { \
uptr_t *rem_args = refer(args); \
coll = TO_INT(eval(env, CAR(*rem_args))); \
*rem_args = CDR(*rem_args); \
while (*rem_args) { \
coll _ARITH_OPR TO_INT(eval(env, CAR(*rem_args))); \
*rem_args = CDR(*rem_args); \
} \
release(1); \
}
#define _ARITH_OPR +=
case S_PLUS: {
if (! args) return INTERN_INT(0);
if (! CDR(args)) return eval(env, CAR(args));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR -=
case S_MINUS: {
if (! args) return NIL;
if (! CDR(args)) return INTERN_INT(0 - TO_INT(eval(env, CAR(args))));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR *=
case S_MULT: {
if (! args) return INTERN_INT(1);
if (! CDR(args)) return eval(env, CAR(args));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR /=
case S_DIV: {
if (! args) return NIL;
if (! CDR(args)) return INTERN_INT(eval(env, CAR(args)) == INTERN_INT(1) ? 1 : 0);
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR &=
case S_BAND: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR |=
case S_BOR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR ^=
case S_BXOR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR <<=
case S_BSL: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR >>=
case S_BSR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
case S_SREG: {
uptr_t *args_p = refer(args),
reg = eval(env, CAR(*args_p));
if (IS_REG(reg))
*BYTE_PTR(reg) = eval(env, CADR(*args_p));
else {
printf_P(PSTR("Invalid register: "));
print_form(reg);
printf_P(PSTR("\n"));
}
release(1); // args_p
return NIL;
}
case S_SLP:
_delay_ms(TO_INT(eval(env, CAR(args))));
return NIL;
default:
printf_P(PSTR("ERROR: "));
print_form(fn);
printf_P(PSTR(" is not a function.\n"));
return NIL;
}
}
SEXP fastmean(SEXP args)
{
long double s = 0., t = 0.;
R_len_t i, l = 0, n = 0;
SEXP x, ans, tmp;
Rboolean narm=FALSE;
x=CADR(args);
if (length(args)>2) {
tmp = CADDR(args);
if (!isLogical(tmp) || LENGTH(tmp)!=1 || LOGICAL(tmp)[0]==NA_LOGICAL)
error("narm should be TRUE or FALSE");
narm=LOGICAL(tmp)[0];
}
PROTECT(ans = allocNAVector(REALSXP, 1));
if (!isInteger(x) && !isReal(x) && !isLogical(x)) {
warning("argument is not numeric or logical: returning NA");
UNPROTECT(1);
return(ans);
}
l = LENGTH(x);
if (narm) {
switch(TYPEOF(x)) {
case LGLSXP:
case INTSXP:
for (i = 0; i<l; i++) {
if(INTEGER(x)[i] == NA_INTEGER) continue;
s += INTEGER(x)[i]; // no under/overflow here, s is long double not integer
n++;
}
if (n>0)
REAL(ans)[0] = (double) (s/n);
else
REAL(ans)[0] = R_NaN; // consistent with base: mean(NA,na.rm=TRUE)==NaN==mean(numeric(),na.rm=TRUE)
break;
case REALSXP:
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) continue; // TO DO: could drop this line and let NA propogate?
s += REAL(x)[i];
n++;
}
if (n==0) {
REAL(ans)[0] = R_NaN;
break;
}
s /= n;
if(R_FINITE((double)s)) {
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) continue;
t += (REAL(x)[i] - s);
}
s += t/n;
}
REAL(ans)[0] = (double) s;
break;
default:
error("Type '%s' not supported in fastmean", type2char(TYPEOF(x)));
}
} else { // narm==FALSE
switch(TYPEOF(x)) {
case LGLSXP:
case INTSXP:
for (i = 0; i<l; i++) {
if(INTEGER(x)[i] == NA_INTEGER) {UNPROTECT(1); return(ans);}
s += INTEGER(x)[i];
}
REAL(ans)[0] = (double) (s/l);
break;
case REALSXP:
for (i = 0; i<l; i++) {
if(ISNAN(REAL(x)[i])) {UNPROTECT(1); return(ans);}
s += REAL(x)[i];
}
s /= l;
if(R_FINITE((double)s)) {
for (i = 0; i<l; i++) {
// no NA if got this far
t += (REAL(x)[i] - s);
}
s += t/LENGTH(x);
}
REAL(ans)[0] = (double) s;
break;
default:
error("Type '%s' not supported in fastmean", type2char(TYPEOF(x)));
}
}
copyMostAttrib(x, ans);
UNPROTECT(1);
return(ans);
}
Result* nth_prototype(SEXP call, const ILazySubsets& subsets, int nargs) {
// has to have at least two arguments
if (nargs < 2) return 0;
SEXP tag = TAG(CDR(call));
if (tag != R_NilValue && tag != Rf_install("x")) {
stop("the first argument of 'nth' should be either 'x' or unnamed");
}
SEXP data = CADR(call);
if (TYPEOF(data) == SYMSXP) {
if (! subsets.count(data)) {
stop("could not find variable '%s'", CHAR(PRINTNAME(data)));
}
data = subsets.get_variable(data);
}
tag = TAG(CDDR(call));
if (tag != R_NilValue && tag != Rf_install("n")) {
stop("the second argument of 'first' should be either 'n' or unnamed");
}
SEXP nidx = CADDR(call);
if ((TYPEOF(nidx) != REALSXP && TYPEOF(nidx) != INTSXP) || LENGTH(nidx) != 1) {
// we only know how to handle the case where nidx is a length one
// integer or numeric. In any other case, e.g. an expression for R to evaluate
// we just fallback to R evaluation (#734)
return 0;
}
int idx = as<int>(nidx);
// easy case : just a single variable: first(x,n)
if (nargs == 2) {
switch (TYPEOF(data)) {
case INTSXP:
return new Nth<INTSXP>(data, idx);
case REALSXP:
return new Nth<REALSXP>(data, idx);
case STRSXP:
return new Nth<STRSXP>(data, idx);
case LGLSXP:
return new Nth<LGLSXP>(data, idx);
default:
break;
}
} else {
// now get `order_by` and default
SEXP order_by = R_NilValue;
SEXP def = R_NilValue;
SEXP p = CDR(CDDR(call));
while (p != R_NilValue) {
SEXP tag = TAG(p);
if (tag == R_NilValue) stop("all arguments of 'first' after the first one should be named");
std::string argname = CHAR(PRINTNAME(tag));
if (argmatch("order_by", argname)) {
order_by = CAR(p);
} else if (argmatch("default", argname)) {
def = CAR(p);
} else {
stop("argument to 'first' does not match either 'default' or 'order_by' ");
}
p = CDR(p);
}
// handle cases
if (def == R_NilValue) {
// then we know order_by is not NULL, we only handle the case where
// order_by is a symbol and that symbol is in the data
if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
order_by = subsets.get_variable(order_by);
switch (TYPEOF(data)) {
case LGLSXP:
return nth_with<LGLSXP>(data, idx, order_by);
case INTSXP:
return nth_with<INTSXP>(data, idx, order_by);
case REALSXP:
return nth_with<REALSXP>(data, idx, order_by);
case STRSXP:
return nth_with<STRSXP>(data, idx, order_by);
default:
break;
}
}
else {
return 0;
}
} else {
if (order_by == R_NilValue) {
switch (TYPEOF(data)) {
case LGLSXP:
return nth_noorder_default<LGLSXP>(data, idx, def);
case INTSXP:
return nth_noorder_default<INTSXP>(data, idx, def);
case REALSXP:
return nth_noorder_default<REALSXP>(data, idx, def);
case STRSXP:
return nth_noorder_default<STRSXP>(data, idx, def);
default:
break;
}
} else {
if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
order_by = subsets.get_variable(order_by);
switch (TYPEOF(data)) {
case LGLSXP:
return nth_with_default<LGLSXP>(data, idx, order_by, def);
case INTSXP:
return nth_with_default<INTSXP>(data, idx, order_by, def);
case REALSXP:
return nth_with_default<REALSXP>(data, idx, order_by, def);
case STRSXP:
return nth_with_default<STRSXP>(data, idx, order_by, def);
default:
break;
}
}
else {
return 0;
}
}
}
}
stop("Unsupported vector type %s", Rf_type2char(TYPEOF(data)));
return 0;
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
R_xlen_t i, len;
int allowNA;
size_t ntype;
int nc;
const char *type;
const char *xi;
wchar_t *wc;
const void *vmax;
checkArity(op, args);
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nchar()");
len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
PROTECT(s = allocVector(INTSXP, len));
vmax = vmaxget();
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
if (sxi == NA_STRING) {
INTEGER(s)[i] = 2;
continue;
}
if (strncmp(type, "bytes", ntype) == 0) {
INTEGER(s)[i] = LENGTH(sxi);
} else if (strncmp(type, "chars", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
nc = 0;
for( ; *p; p += utf8clen(*p)) nc++;
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do chars 0 */
error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
nc = (int) mbstowcs(NULL, translateChar(sxi), 0);
if (!allowNA && nc < 0)
error(_("invalid multibyte string %d"), i+1);
INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER;
} else
INTEGER(s)[i] = (int) strlen(translateChar(sxi));
} else if (strncmp(type, "width", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
wchar_t wc1;
nc = 0;
for( ; *p; p += utf8clen(*p)) {
utf8toucs(&wc1, p);
nc += Ri18n_wcwidth(wc1);
}
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do width 0 */
error(_("width is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
xi = translateChar(sxi);
nc = (int) mbstowcs(NULL, xi, 0);
if (nc >= 0) {
wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff);
mbstowcs(wc, xi, nc + 1);
INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647);
if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc;
} else if (allowNA)
error(_("invalid multibyte string %d"), i+1);
else
INTEGER(s)[i] = NA_INTEGER;
} else
INTEGER(s)[i] = (int) strlen(translateChar(sxi));
} else
error(_("invalid '%s' argument"), "type");
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
Obj assVal(Obj expr) {
return CADDR(GETLIST(expr));
}
T eval_defun(T form, Environment env) {
Object name = CADR(form);
Object value = mklambda(CADDR(form), CADDDR(form), env);
defglobal(name, value);
return name;
}
static SCM
expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
SCM inits;
int nreq, nopt;
const long length = scm_ilength (clause);
ASSERT_SYNTAX (length >= 1, s_bad_expression,
scm_cons (sym_lambda_star, clause));
ASSERT_SYNTAX (length >= 2, s_missing_expression,
scm_cons (sym_lambda_star, clause));
formals = CAR (clause);
body = CDR (clause);
nreq = nopt = 0;
req = opt = kw = SCM_EOL;
rest = allow_other_keys = SCM_BOOL_F;
while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
{
nreq++;
req = scm_cons (CAR (formals), req);
formals = scm_cdr (formals);
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
nopt++;
opt = scm_cons (CAR (formals), opt);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
kw = scm_cons (CAR (formals), kw);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
{
formals = CDR (formals);
allow_other_keys = SCM_BOOL_T;
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
{
ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
CAR (clause));
rest = CADR (formals);
}
else if (scm_is_symbol (formals))
rest = formals;
else
{
ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
rest = SCM_BOOL_F;
}
/* Now, iterate through them a second time, building up an expansion-time
environment, checking, expanding and canonicalizing the opt/kw init forms,
and eventually memoizing the body as well. Note that the rest argument, if
any, is expanded before keyword args, thus necessitating the second
pass.
Also note that the specific environment during expansion of init
expressions here needs to coincide with the environment when psyntax
expands. A lot of effort for something that is only used in the bootstrap
expandr, you say? Yes. Yes it is.
*/
vars = SCM_EOL;
req = scm_reverse_x (req, SCM_EOL);
for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (CAR (tmp), CAR (vars), env);
}
/* Build up opt inits and env */
inits = SCM_EOL;
opt = scm_reverse_x (opt, SCM_EOL);
for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
SCM x = CAR (tmp);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x))
inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
else
{
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
s_bad_formals, CAR (clause));
inits = scm_cons (expand (CADR (x), env), inits);
}
env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
}
if (scm_is_null (opt))
opt = SCM_BOOL_F;
/* Process rest before keyword args */
if (scm_is_true (rest))
{
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (rest, CAR (vars), env);
}
/* Build up kw inits, env, and kw-canon list */
if (scm_is_null (kw))
kw = SCM_BOOL_F;
else
{
SCM kw_canon = SCM_EOL;
kw = scm_reverse_x (kw, SCM_UNDEFINED);
for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
SCM x, sym, k, init;
x = CAR (tmp);
if (scm_is_symbol (x))
{
sym = x;
init = SCM_BOOL_F;
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
{
sym = CAR (x);
init = CADR (x);
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
&& scm_is_keyword (CADDR (x)))
{
sym = CAR (x);
init = CADR (x);
k = CADDR (x);
}
else
syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
inits = scm_cons (expand (init, env), inits);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
env = scm_acons (sym, CAR (vars), env);
}
kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
kw = scm_cons (allow_other_keys, kw_canon);
}
/* We should check for no duplicates, but given that psyntax does this
already, we can punt on it here... */
vars = scm_reverse_x (vars, SCM_UNDEFINED);
inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = expand_sequence (body, env);
return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
alternate);
}
static lisp_cell_t *subr_fma(lisp_t *l, lisp_cell_t *args)
{
return mk_float(l, fma(get_a2f(car(args)), get_a2f(CADR(args)), get_a2f(CADDR(args))));
}
static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
abort ();
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
case SCM_EXPANDED_TOPLEVEL_SET:
return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
memoize (REF (exp, TOPLEVEL_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
}
case SCM_EXPANDED_PRIMCALL:
{
SCM name, args;
int nargs;
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
nargs,
args);
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */
{
SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
body = REF (exp, LAMBDA, BODY);
if (scm_is_false (body))
/* Give a body to case-lambda with no clauses. */
proc = MAKMEMO_LAMBDA
(MAKMEMO_CALL
(MAKMEMO_MOD_REF (list_of_guile,
scm_from_latin1_symbol ("throw"),
SCM_BOOL_F),
5,
scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
MAKMEMO_QUOTE (SCM_BOOL_F),
MAKMEMO_QUOTE (scm_from_latin1_string
("Wrong number of arguments")),
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
SCM_BOOL_F /* docstring */);
else
proc = memoize (body, env);
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
SCM_SETCAR (SCM_CDR (args), docstring);
}
return proc;
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env;
int nreq, nopt, ntotal;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);
vars = REF (exp, LAMBDA_CASE, GENSYMS);
body = REF (exp, LAMBDA_CASE, BODY);
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ntotal = scm_ilength (vars);
/* The vars are the gensyms, according to the divine plan. But we need
to memoize the inits within their appropriate environment,
complicating things. */
new_env = env;
for (walk = req; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars))
new_env = scm_cons (CAR (vars), new_env);
minits = SCM_EOL;
for (walk = opt; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (scm_is_true (rest))
{
new_env = scm_cons (CAR (vars), new_env);
vars = CDR (vars);
}
for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (!scm_is_null (vars))
abort ();
minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))
arity = FIXED_ARITY (nreq);
else
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_BOOL_F /* docstring */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, inits, new_env;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
inits = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
{
new_env = scm_cons (CAR (vars), new_env);
inits = scm_cons (memoize (CAR (exps), env), inits);
}
return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
memoize (body, new_env));
}
case SCM_EXPANDED_LETREC:
{
SCM vars, exps, body, undefs, new_env;
int i, nvars, in_order_p;
vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY);
in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
nvars = i = scm_ilength (vars);
undefs = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
}
if (in_order_p)
{
SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
body_exps);
seq = memoize (body, new_env);
for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
sets = scm_reverse_x (sets, SCM_UNDEFINED);
if (scm_is_null (sets))
return memoize (body, env);
for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
sets = CDR (sets))
set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
return MAKMEMO_LET (undefs,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
memoize (body, new_env)));
}
}
default:
abort ();
}
}
Obj ifThen(Obj expr) { return CADDR(expr); }
Obj funcBody(Obj obj) { return CADDR(obj); }
/* **************************************************************************
* RshpCentrd_2d
*
* Return the single mathematical / geometric centroid of a potentially
* complex/compound RShapeObject
*
* reject non area SHP Types
*
* **************************************************************************/
SEXP RshpCentrd_2d (SEXP call) {
int ring, ringPrev, ring_nVertices, rStart, nprts;
int i,j,totvert;
double Area, ringArea;
SEXP ringCentrd, Cent, shape, flag, ringVerts;
shape = CADR(call);
flag = CADDR(call);
/* if ( !(SHPDimension(INTEGER(getAttrib(shape,install("shp.type")))[0]) */
/* & SHPD_AREA) ) */
/* error("Not a class of shape with defined 2d area"); */
nprts = INTEGER(getAttrib(shape, install("nParts")))[0];
Area = 0;
if(INTEGER(flag)[0]==0 ||nprts==1){
PROTECT(Cent=allocVector(REALSXP, 2));
REAL(Cent)[0] = 0.0;
REAL(Cent)[1] = 0.0;
}
else{
PROTECT(Cent=allocMatrix(REALSXP, nprts, 2));
}
/* for each ring in compound / complex object calc the ring cntrd */
ringPrev = INTEGER(getAttrib(shape, install("nVerts")))[0];
totvert = INTEGER(getAttrib(shape, install("nVerts")))[0];
if(nprts==0) nprts=1;
for ( ring = nprts-1; ring >= 0; ring-- ) {
rStart = INTEGER(VECTOR_ELT(shape,0))[ring];
ring_nVertices = ringPrev - rStart;
/* Rprintf("ringPrev= %d, rStart=%d, ring_nVertices=%d \n", */
/* ringPrev, rStart, ring_nVertices); */
PROTECT(ringVerts=allocMatrix(REALSXP, ring_nVertices, 2));
for(i=rStart,j=0;i<ringPrev ;i++,j++){
REAL(ringVerts)[j]=REAL(VECTOR_ELT(shape,1))[i];
REAL(ringVerts)[j+ring_nVertices]=REAL(VECTOR_ELT(shape,1))[i+totvert];
}
/* Rprintf(" matrix begin %f, matrix end: %f \n", */
/* REAL(ringVerts)[0],REAL(ringVerts)[(2*ring_nVertices)-1]); */
PROTECT(ringCentrd =
R_RingCentrd_2d (ring_nVertices, ringVerts, &ringArea));
/* Rprintf("xcent: %f, ycent: %f, area: %f\n ", */
/* REAL(ringCentrd)[0],REAL(ringCentrd)[1],ringArea ); */
/* use Superposition of these rings to build a composite Centroid */
/* sum the ring centrds * ringAreas, at the end divide by total area */
if(INTEGER(flag)[0]==0 ||nprts==1){
REAL(Cent)[0] += REAL(ringCentrd)[0] * ringArea;
REAL(Cent)[1] += REAL(ringCentrd)[1] * ringArea;
}
else{
REAL(Cent)[ring]= REAL(ringCentrd)[0];
REAL(Cent)[ring+nprts]= REAL(ringCentrd)[1];
}
Area += ringArea;
ringPrev = rStart;
UNPROTECT(2);
}
/* hold on the division by AREA until were at the end */
if(INTEGER(flag)[0]==0 ||nprts==1){
REAL(Cent)[0] = REAL(Cent)[0] / Area;
REAL(Cent)[1] = REAL(Cent)[1] / Area;
UNPROTECT(1);
return ( Cent );
}
else{
UNPROTECT(1);
return ( Cent );
}
}
Obj defVal(Obj expr) {
return CADDR(GETLIST(expr));
}
T eval_lambda(T form, Environment env) {
Object args = CADR(form);
Object body = CADDR(form);
return mklambda(args, body, env);
}
Obj ifThen(Obj expr) {
return CADDR(GETLIST(expr));
}
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
int m, zero = 0;
R_xlen_t *lengths, *counters, longest = 0;
m = length(varyingArgs);
SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue);
lengths = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
for (int i = 0; i < m; i++) {
SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
lengths[i] = xlength(tmp1);
if (isObject(tmp1)) { // possibly dispatch on length()
/* Cache the .Primitive: unclear caching is worthwhile. */
static SEXP length_op = NULL;
if (length_op == NULL) length_op = R_Primitive("length");
// DispatchOrEval() needs 'args' to be a pairlist
SEXP ans, tmp2 = PROTECT(list1(tmp1));
if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ?
REAL(ans)[0] : asInteger(ans)));
UNPROTECT(1);
}
if (lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("zero-length inputs cannot be mixed with those of non-zero length"));
counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
memset(counters, 0, m * sizeof(R_xlen_t));
SEXP mindex = PROTECT(allocVector(VECSXP, m));
SEXP nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
SEXP fcall = R_NilValue; // -Wall
if (constantArgs == R_NilValue)
;
else if (isVectorList(constantArgs))
fcall = VectorToPairList(constantArgs);
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
PROTECT_INDEX fi;
PROTECT_WITH_INDEX(fcall, &fi);
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX);
SEXP Dots = install("dots");
for (int j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
REPROTECT(fcall = CONS(tmp2, fcall), fi);
UNPROTECT(2);
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
}
REPROTECT(fcall = LCONS(f, fcall), fi);
SEXP ans = PROTECT(allocVector(VECSXP, longest));
for (int i = 0; i < longest; i++) {
for (int j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
if (realIndx)
REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]);
else
INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]);
}
SEXP tmp = eval(fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
for (int j = 0; j < m; j++)
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
UNPROTECT(5);
return ans;
}
Obj lambdaBody(Obj expr) {
return CADDR(GETLIST(expr));
}
SEXP typeconvert(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP cvec, a, dup, levs, dims, names, dec;
SEXP rval = R_NilValue; /* -Wall */
int i, j, len, asIs;
Rboolean done = FALSE;
char *endp;
const char *tmp = NULL;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
Typecvt_Info typeInfo; /* keep track of possible types of cvec */
typeInfo.islogical = TRUE; /* we can't rule anything out initially */
typeInfo.isinteger = TRUE;
typeInfo.isreal = TRUE;
typeInfo.iscomplex = TRUE;
data.NAstrings = R_NilValue;
args = CDR(args);
if (!isString(CAR(args)))
error(_("the first argument must be of mode character"));
data.NAstrings = CADR(args);
if (TYPEOF(data.NAstrings) != STRSXP)
error(_("invalid '%s' argument"), "na.strings");
asIs = asLogical(CADDR(args));
if (asIs == NA_LOGICAL) asIs = 0;
dec = CADDDR(args);
if (isString(dec) || isNull(dec)) {
if (length(dec) == 0)
data.decchar = '.';
else
data.decchar = translateChar(STRING_ELT(dec, 0))[0];
}
cvec = CAR(args);
len = length(cvec);
/* save the dim/dimnames attributes */
PROTECT(dims = getAttrib(cvec, R_DimSymbol));
if (isArray(cvec))
PROTECT(names = getAttrib(cvec, R_DimNamesSymbol));
else
PROTECT(names = getAttrib(cvec, R_NamesSymbol));
/* Use the first non-NA to screen */
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (!(STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp)))
break;
}
if (i < len) { /* not all entries are NA */
ruleout_types(tmp, &typeInfo, &data);
}
if (typeInfo.islogical) {
PROTECT(rval = allocVector(LGLSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
LOGICAL(rval)[i] = NA_LOGICAL;
else {
if (strcmp(tmp, "F") == 0 || strcmp(tmp, "FALSE") == 0)
LOGICAL(rval)[i] = 0;
else if(strcmp(tmp, "T") == 0 || strcmp(tmp, "TRUE") == 0)
LOGICAL(rval)[i] = 1;
else {
typeInfo.islogical = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if (typeInfo.islogical) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isinteger) {
PROTECT(rval = allocVector(INTSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
INTEGER(rval)[i] = NA_INTEGER;
else {
INTEGER(rval)[i] = Strtoi(tmp, 10);
if (INTEGER(rval)[i] == NA_INTEGER) {
typeInfo.isinteger = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isinteger) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isreal) {
PROTECT(rval = allocVector(REALSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
REAL(rval)[i] = NA_REAL;
else {
REAL(rval)[i] = Strtod(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.isreal = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isreal) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.iscomplex) {
PROTECT(rval = allocVector(CPLXSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
COMPLEX(rval)[i].r = COMPLEX(rval)[i].i = NA_REAL;
else {
COMPLEX(rval)[i] = strtoc(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.iscomplex = FALSE;
/* this is not needed, unless other cases are added */
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.iscomplex) done = TRUE; else UNPROTECT(1);
}
if (!done) {
if (asIs) {
PROTECT(rval = duplicate(cvec));
for (i = 0; i < len; i++)
if(isNAstring(CHAR(STRING_ELT(rval, i)), 1, &data))
SET_STRING_ELT(rval, i, NA_STRING);
}
else {
PROTECT(dup = duplicated(cvec, FALSE));
j = 0;
for (i = 0; i < len; i++) {
/* <NA> is never to be a level here */
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
j++;
}
PROTECT(levs = allocVector(STRSXP,j));
j = 0;
for (i = 0; i < len; i++) {
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
SET_STRING_ELT(levs, j++, STRING_ELT(cvec, i));
}
/* We avoid an allocation by reusing dup,
* a LGLSXP of the right length
*/
rval = dup;
SET_TYPEOF(rval, INTSXP);
/* put the levels in lexicographic order */
sortVector(levs, FALSE);
PROTECT(a = matchE(levs, cvec, NA_INTEGER, env));
for (i = 0; i < len; i++)
INTEGER(rval)[i] = INTEGER(a)[i];
setAttrib(rval, R_LevelsSymbol, levs);
PROTECT(a = mkString("factor"));
setAttrib(rval, R_ClassSymbol, a);
UNPROTECT(3);
}
}
setAttrib(rval, R_DimSymbol, dims);
setAttrib(rval, isArray(cvec) ? R_DimNamesSymbol : R_NamesSymbol, names);
UNPROTECT(3);
return rval;
}
SEXP Win_selectlist(SEXP args)
{
SEXP choices, preselect, ans = R_NilValue;
const char **clist;
int i, j = -1, n, mw = 0, multiple, nsel = 0;
int xmax, ymax, ylist, fht, h0;
Rboolean haveTitle;
choices = CAR(args);
if(!isString(choices)) error(_("invalid '%s' argument"), "choices");
preselect = CADR(args);
if(!isNull(preselect) && !isString(preselect))
error(_("invalid '%s' argument"), "preselect");
multiple = asLogical(CADDR(args));
if(multiple == NA_LOGICAL) multiple = 0;
haveTitle = isString(CADDDR(args));
if(!multiple && isString(preselect) && LENGTH(preselect) != 1)
error(_("invalid '%s' argument"), "preselect");
n = LENGTH(choices);
clist = (const char **) R_alloc(n + 1, sizeof(char *));
for(i = 0; i < n; i++) {
clist[i] = translateChar(STRING_ELT(choices, i));
mw = max(mw, gstrwidth(NULL, SystemFont, clist[i]));
}
clist[n] = NULL;
fht = getSysFontSize().height;
xmax = max(170, mw+60); /* allow for scrollbar */
if(ismdi()) {
RECT *pR = RgetMDIsize();
h0 = pR->bottom;
} else {
h0 = deviceheight(NULL);
}
ymax = min(80+fht*n, h0-100); /* allow for window widgets, toolbar */
ylist = ymax - 60;
wselect = newwindow(haveTitle ? translateChar(STRING_ELT(CADDDR(args), 0)):
(multiple ? _("Select one or more") : _("Select one")),
rect(0, 0, xmax, ymax),
Titlebar | Centered | Modal | Floating);
setbackground(wselect, dialog_bg());
if(multiple)
f_list = newmultilist(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
else
f_list = newlistbox(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
if(!isNull(preselect) && LENGTH(preselect)) {
for(i = 0; i < n; i++)
for(j = 0; j < LENGTH(preselect); j++)
if(strcmp(clist[i], translateChar(STRING_ELT(preselect, j))) == 0) {
setlistitem(f_list, i);
break;
}
}
bFinish = newbutton(G_("OK"), rect(xmax-160, ymax-40, 70, 25), finish);
bCancel = newbutton(G_("Cancel"), rect(xmax-80, ymax-40, 70, 25), cancel);
setkeydown(wselect, key1);
show(wselect);
done = 0;
while(!done) {
R_WaitEvent();
R_ProcessEvents();
}
if(multiple) {
if (done == 1) { /* Finish */
for(i = 0; i < n; i++) if(isselected(f_list, i)) nsel++;
PROTECT(ans = allocVector(STRSXP, nsel));
for(i = 0, j = 0; i < n; i++)
if(isselected(f_list, i))
SET_STRING_ELT(ans, j++, mkChar(clist[i]));
} else { /* cancel */
PROTECT(ans = allocVector(STRSXP, 0));
}
} else
PROTECT(ans = mkString(selected));
cleanup();
show(RConsole);
R_ProcessEvents();
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden do_substrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, value, el, v_el;
R_xlen_t i, len;
int start, stop, k, l, v;
size_t slen;
cetype_t ienc, venc;
const char *ss, *v_ss;
char *buf;
const void *vmax;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
value = CADDDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("replacing substrings in a non-character object"));
len = LENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
v = LENGTH(value);
if (!isString(value) || v == 0) error(_("invalid value"));
vmax = vmaxget();
for (i = 0; i < len; i++) {
el = STRING_ELT(x, i);
v_el = STRING_ELT(value, i % v);
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
if (el == NA_STRING || v_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);
if (start < 1) start = 1;
if (stop > slen) stop = (int) slen; /* SBCS optimization */
if (start > stop) {
/* just copy element across */
SET_STRING_ELT(s, i, STRING_ELT(x, i));
} else {
int ienc2 = ienc;
v_ss = CHAR(v_el);
/* is the value in the same encoding?
FIXME: could prefer UTF-8 here
*/
venc = getCharCE(v_el);
if (venc != ienc && !strIsASCII(v_ss)) {
ss = translateChar(el);
slen = strlen(ss);
v_ss = translateChar(v_el);
ienc2 = CE_NATIVE;
}
/* might expand under MBCS */
buf = R_AllocStringBuffer(slen+strlen(v_ss), &cbuff);
strcpy(buf, ss);
substrset(buf, v_ss, ienc2, start, stop);
SET_STRING_ELT(s, i, mkCharCE(buf, ienc2));
}
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
}
UNPROTECT(1);
return s;
}
/* Note that NA_STRING is not handled separately here. This is
deliberate -- see ?paste -- and implicitly coerces it to "NA"
*/
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, collapse, sep, x;
int sepw, u_sepw, ienc;
R_xlen_t i, j, k, maxlen, nx, pwidth;
const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
char *buf;
Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
use_sep = (PRIMVAL(op) == 0);
const void *vmax;
checkArity(op, args);
/* We use formatting and so we must initialize printing. */
PrintDefaults();
/* Check the arguments */
x = CAR(args);
if (!isVectorList(x))
error(_("invalid first argument"));
nx = xlength(x);
if(use_sep) { /* paste(..., sep, .) */
sep = CADR(args);
if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
error(_("invalid separator"));
sep = STRING_ELT(sep, 0);
csep = translateChar(sep);
u_sepw = sepw = (int) strlen(csep); // will be short
sepASCII = strIsASCII(csep);
sepKnown = ENC_KNOWN(sep) > 0;
sepUTF8 = IS_UTF8(sep);
sepBytes = IS_BYTES(sep);
collapse = CADDR(args);
} else { /* paste0(..., .) */
u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
collapse = CADR(args);
}
if (!isNull(collapse))
if(!isString(collapse) || LENGTH(collapse) <= 0 ||
STRING_ELT(collapse, 0) == NA_STRING)
error(_("invalid '%s' argument"), "collapse");
if(nx == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
/* Maximum argument length, coerce if needed */
maxlen = 0;
for (j = 0; j < nx; j++) {
if (!isString(VECTOR_ELT(x, j))) {
/* formerly in R code: moved to C for speed */
SEXP call, xj = VECTOR_ELT(x, j);
if(OBJECT(xj)) { /* method dispatch */
PROTECT(call = lang2(install("as.character"), xj));
SET_VECTOR_ELT(x, j, eval(call, env));
UNPROTECT(1);
} else if (isSymbol(xj))
SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
else
SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
if (!isString(VECTOR_ELT(x, j)))
error(_("non-string argument to internal 'paste'"));
}
if(xlength(VECTOR_ELT(x, j)) > maxlen)
maxlen = xlength(VECTOR_ELT(x, j));
}
if(maxlen == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
PROTECT(ans = allocVector(STRSXP, maxlen));
for (i = 0; i < maxlen; i++) {
/* Strategy for marking the encoding: if all inputs (including
* the separator) are ASCII, so is the output and we don't
* need to mark. Otherwise if all non-ASCII inputs are of
* declared encoding, we should mark.
* Need to be careful only to include separator if it is used.
*/
anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
if(nx > 1) {
allKnown = sepKnown || sepASCII;
anyKnown = sepKnown;
use_UTF8 = sepUTF8;
use_Bytes = sepBytes;
}
pwidth = 0;
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if(IS_UTF8(cs)) use_UTF8 = TRUE;
if(IS_BYTES(cs)) use_Bytes = TRUE;
}
}
if (use_Bytes) use_UTF8 = FALSE;
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
if(use_Bytes)
pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else if(use_UTF8)
pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else
pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
vmaxset(vmax);
}
}
if(use_sep) {
if (use_UTF8 && !u_csep) {
u_csep = translateCharUTF8(sep);
u_sepw = (int) strlen(u_csep); // will be short
}
pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
}
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if (use_UTF8) {
s = translateCharUTF8(cs);
strcpy(buf, s);
buf += strlen(s);
} else {
s = use_Bytes ? CHAR(cs) : translateChar(cs);
strcpy(buf, s);
buf += strlen(s);
allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
}
}
if (sepw != 0 && j != nx - 1) {
if (use_UTF8) {
strcpy(buf, u_csep);
buf += u_sepw;
} else {
strcpy(buf, csep);
buf += sepw;
}
}
vmax = vmaxget();
}
ienc = 0;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
}
/* Now collapse, if required. */
if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
sep = STRING_ELT(collapse, 0);
use_UTF8 = IS_UTF8(sep);
use_Bytes = IS_BYTES(sep);
for (i = 0; i < nx; i++) {
if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
}
if(use_Bytes) {
csep = CHAR(sep);
use_UTF8 = FALSE;
} else if(use_UTF8)
csep = translateCharUTF8(sep);
else
csep = translateChar(sep);
sepw = (int) strlen(csep);
anyKnown = ENC_KNOWN(sep) > 0;
allKnown = anyKnown || strIsASCII(csep);
pwidth = 0;
vmax = vmaxget();
for (i = 0; i < nx; i++)
if(use_UTF8) {
pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
vmaxset(vmax);
} else /* already translated */
pwidth += strlen(CHAR(STRING_ELT(ans, i)));
pwidth += (nx - 1) * sepw;
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (i = 0; i < nx; i++) {
if(i > 0) {
strcpy(buf, csep);
buf += sepw;
}
if(use_UTF8)
s = translateCharUTF8(STRING_ELT(ans, i));
else /* already translated */
s = CHAR(STRING_ELT(ans, i));
strcpy(buf, s);
while (*buf)
buf++;
allKnown = allKnown &&
(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
if(use_UTF8) vmaxset(vmax);
}
UNPROTECT(1);
ienc = CE_NATIVE;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
}
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return ans;
}
void CallProxy::traverse_call( SEXP obj ){
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("global") ){
SEXP symb = CADR(obj) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find(CHAR(PRINTNAME(symb))) ;
call = res ;
return ;
}
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("column") ){
call = get_column(CADR(obj), env, subsets) ;
return ;
}
if( ! Rf_isNull(obj) ){
SEXP head = CAR(obj) ;
switch( TYPEOF( head ) ){
case LANGSXP:
if( CAR(head) == Rf_install("global") ){
SEXP symb = CADR(head) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find( CHAR(PRINTNAME(symb)) ) ;
SETCAR(obj, res) ;
SET_TYPEOF(obj, LISTSXP) ;
break ;
}
if( CAR(head) == Rf_install("column")){
Symbol column = get_column( CADR(head), env, subsets) ;
SETCAR(obj, column ) ;
head = CAR(obj) ;
proxies.push_back( CallElementProxy( head, obj ) );
break ;
}
if( CAR(head) == Rf_install("~")) break ;
if( CAR(head) == Rf_install("order_by") ) break ;
if( CAR(head) == Rf_install("function") ) break ;
if( CAR(head) == Rf_install("local") ) return ;
if( CAR(head) == Rf_install("<-") ){
stop( "assignments are forbidden" ) ;
}
if( Rf_length(head) == 3 ){
SEXP symb = CAR(head) ;
if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){
// Rprintf( "CADR(obj) = " ) ;
// Rf_PrintValue( CADR(obj) ) ;
// for things like : foo( bar = bling )$bla
// so that `foo( bar = bling )` gets processed
if( TYPEOF(CADR(head)) == LANGSXP ){
traverse_call( CDR(head) ) ;
}
// deal with foo$bar( bla = boom )
if( TYPEOF(CADDR(head)) == LANGSXP ){
traverse_call( CDDR(head) ) ;
}
break ;
} else {
traverse_call( CDR(head) ) ;
}
} else {
traverse_call( CDR(head) ) ;
}
break ;
case LISTSXP:
traverse_call( head ) ;
traverse_call( CDR(head) ) ;
break ;
case SYMSXP:
if( TYPEOF(obj) != LANGSXP ){
if( ! subsets.count(head) ){
if( head == R_MissingArg ) break ;
if( head == Rf_install(".") ) break ;
// in the Environment -> resolve
try{
Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;
SETCAR( obj, x );
} catch( ...){
// what happens when not found in environment
}
} else {
// in the data frame
proxies.push_back( CallElementProxy( head, obj ) );
}
break ;
}
}
traverse_call( CDR(obj) ) ;
}
}
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x;
int digits, nsmall, no = 1, w, d, e, wi, di, ei;
checkArity(op, args);
x = CAR(args);
R_xlen_t n = XLENGTH(x);
PrintDefaults();
digits = asInteger(CADR(args));
if (!isNull(CADR(args))) {
digits = asInteger(CADR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
nsmall = asInteger(CADDR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
w = 0;
d = 0;
e = 0;
switch (TYPEOF(x)) {
case RAWSXP:
formatRaw(RAW(x), n, &w);
break;
case LGLSXP:
formatLogical(LOGICAL(x), n, &w);
break;
case INTSXP:
formatInteger(INTEGER(x), n, &w);
break;
case REALSXP:
no = 3;
formatReal(REAL(x), n, &w, &d, &e, nsmall);
break;
case CPLXSXP:
no = 6;
wi = di = ei = 0;
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
break;
case STRSXP:
for (R_xlen_t i = 0; i < n; i++)
if (STRING_ELT(x, i) != NA_STRING) {
int il = Rstrlen(STRING_ELT(x, i), 0);
if (il > w) w = il;
}
break;
default:
error(_("atomic vector arguments only"));
}
x = allocVector(INTSXP, no);
INTEGER(x)[0] = w;
if(no > 1) {
INTEGER(x)[1] = d;
INTEGER(x)[2] = e;
}
if(no > 3) {
INTEGER(x)[3] = wi;
INTEGER(x)[4] = di;
INTEGER(x)[5] = ei;
}
return x;
}
obj_t new_values = CONS(make_unspecified(), cont5_arg2(cont));
obj_t ret = cont_cont(cont);
env_bind(cont_env(cont),
cont5_arg1(cont),
BT_LEXICAL,
M_MUTABLE,
CAR(values));
return cv(ret, new_values);
}
DEFINE_SPECIAL_FORM(L"define")(obj_t cont, obj_t values)
{
assert(is_cont4(cont));
obj_t form = cont4_arg(cont);
obj_t env = cont_env(cont);
EVAL_LOG("form=%O", form);
CHECK(list_length(form) == 3, "define takes 2 arguments");
obj_t var = CADR(form);
obj_t expr = CADDR(form);
obj_t second = make_cont5(c_continue_define,
cont_cont(cont),
env,
var,
CDR(values));
obj_t first = make_cont4(c_eval, second, env, expr);
return cv(first, EMPTY_LIST);
}
TEST_EVAL(L"(define v0 3) v0", L"3");
TEST_EVAL(L"(define v5 1)", UNSPECIFIED_REPR);
SEXP Random2(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a, b;
R_xlen_t i, n, na, nb;
ran2 fn = NULL; /* -Wall */
const char *dn = CHAR(STRING_ELT(getListElement(CAR(args), "name"), 0));
SEXPTYPE type = REALSXP;
if (streql(dn, "rbeta")) fn = &rbeta;
else if (streql(dn, "rbinom")) {
type = INTSXP;
fn = &rbinom;
} else if (streql(dn, "rcauchy")) fn = &rcauchy;
else if (streql(dn, "rf")) fn = &rf;
else if (streql(dn, "rgamma")) fn = &rgamma;
else if (streql(dn, "rlnorm")) fn = &rlnorm;
else if (streql(dn, "rlogis")) fn = &rlogis;
else if (streql(dn, "rnbinom")) {
type = INTSXP;
fn = &rnbinom;
} else if (streql(dn, "rnorm")) fn = &rnorm;
else if (streql(dn, "runif")) fn = &runif;
else if (streql(dn, "rweibull")) fn = &rweibull;
else if (streql(dn, "rwilcox")) {
type = INTSXP;
fn = &rwilcox;
} else if (streql(dn, "rnchisq")) fn = &rnchisq;
else if (streql(dn, "rnbinom_mu")) {
fn = &rnbinom_mu;
} else error(_("invalid arguments"));
args = CDR(args);
if (!isVector(CAR(args)) ||
!isNumeric(CADR(args)) ||
!isNumeric(CADDR(args)))
error(_("invalid arguments"));
if (XLENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(type, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
na = XLENGTH(CADR(args));
nb = XLENGTH(CADDR(args));
if (na < 1 || nb < 1) {
if (type == INTSXP)
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
else
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
warning(_("NAs produced"));
}
else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(CADR(args), REALSXP));
PROTECT(b = coerceVector(CADDR(args), REALSXP));
GetRNGstate();
double *ra = REAL(a), *rb = REAL(b);
if (type == INTSXP) {
int *ix = INTEGER(x); double rx;
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) {
naflag = TRUE;
ix[i] = NA_INTEGER;
} else ix[i] = (int) rx;
}
} else {
double *rx = REAL(x);
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx[i] = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx[i])) naflag = TRUE;
}
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(2);
}
UNPROTECT(1);
return x;
}
/* GetNativeSystemInfo is XP or later */
pGNSI = (PGNSI)
GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
"GetNativeSystemInfo");
if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
strcat(ver, " x64");
}
SET_STRING_ELT(ans, 1, mkChar(ver));
if((int)osvi.dwMajorVersion >= 5) {
if(osvi.wServicePackMajor > 0)
snprintf(ver, 256, "build %d, Service Pack %d",
LOWORD(osvi.dwBuildNumber),
(int) osvi.wServicePackMajor);
else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
} else
snprintf(ver, 256, "build %d, %s",
LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
SET_STRING_ELT(ans, 2, mkChar(ver));
GetComputerNameW(name, &namelen);
wcstoutf8(buf, name, 1000);
SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef _WIN64
SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
GetUserNameW(user, &userlen);
wcstoutf8(buf, user, 1000);
SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
PROTECT(ansnames = allocVector(STRSXP, 8));
SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
SET_STRING_ELT(ansnames, 1, mkChar("release"));
SET_STRING_ELT(ansnames, 2, mkChar("version"));
SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
SET_STRING_ELT(ansnames, 4, mkChar("machine"));
SET_STRING_ELT(ansnames, 5, mkChar("login"));
SET_STRING_ELT(ansnames, 6, mkChar("user"));
SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(2);
return ans;
}
SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
DWORD mtime;
int ntime;
double time;
checkArity(op, args);
time = asReal(CAR(args));
if (ISNAN(time) || time < 0)
errorcall(call, _("invalid '%s' value"), "time");
ntime = 1000*(time) + 0.5;
while (ntime > 0) {
mtime = min(500, ntime);
ntime -= mtime;
Sleep(mtime);
R_ProcessEvents();
}
return R_NilValue;
}
#ifdef LEA_MALLOC
#define MALLINFO_FIELD_TYPE size_t
struct mallinfo {
MALLINFO_FIELD_TYPE arena; /* non-mmapped space allocated from system */
MALLINFO_FIELD_TYPE ordblks; /* number of free chunks */
MALLINFO_FIELD_TYPE smblks; /* number of fastbin blocks */
MALLINFO_FIELD_TYPE hblks; /* number of mmapped regions */
MALLINFO_FIELD_TYPE hblkhd; /* space in mmapped regions */
MALLINFO_FIELD_TYPE usmblks; /* maximum total allocated space */
MALLINFO_FIELD_TYPE fsmblks; /* space available in freed fastbin blocks */
MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
MALLINFO_FIELD_TYPE fordblks; /* total free space */
MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
};
extern R_size_t R_max_memory;
struct mallinfo mallinfo(void);
#endif
SEXP in_memsize(SEXP ssize)
{
SEXP ans;
int maxmem = NA_LOGICAL;
if(isLogical(ssize))
maxmem = asLogical(ssize);
else if(isReal(ssize)) {
R_size_t newmax;
double mem = asReal(ssize);
if (!R_FINITE(mem))
error(_("incorrect argument"));
#ifdef LEA_MALLOC
#ifndef _WIN64
if(mem >= 4096)
error(_("don't be silly!: your machine has a 4Gb address limit"));
#endif
newmax = mem * 1048576.0;
if (newmax < R_max_memory)
warning(_("cannot decrease memory limit: ignored"));
else
R_max_memory = newmax;
#endif
} else
error(_("incorrect argument"));
PROTECT(ans = allocVector(REALSXP, 1));
#ifdef LEA_MALLOC
if(maxmem == NA_LOGICAL)
REAL(ans)[0] = R_max_memory;
else if(maxmem)
REAL(ans)[0] = mallinfo().usmblks;
else
REAL(ans)[0] = mallinfo().uordblks;
REAL(ans)[0] /= 1048576.0;
#else
REAL(ans)[0] = NA_REAL;
#endif
UNPROTECT(1);
return ans;
}
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP path = R_NilValue, ans;
const wchar_t *dll;
DWORD dwVerInfoSize;
DWORD dwVerHnd;
checkArity(op, args);
path = CAR(args);
if(!isString(path) || LENGTH(path) != 1)
errorcall(call, _("invalid '%s' argument"), "path");
dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
PROTECT(ans = allocVector(STRSXP, 2));
SET_STRING_ELT(ans, 0, mkChar(""));
SET_STRING_ELT(ans, 1, mkChar(""));
if (dwVerInfoSize) {
BOOL fRet;
LPSTR lpstrVffInfo;
LPSTR lszVer = NULL;
UINT cchVer = 0;
lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
else {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
}
} else ans = R_NilValue;
free(lpstrVffInfo);
} else ans = R_NilValue;
UNPROTECT(1);
return ans;
}
int Rwin_rename(const char *from, const char *to)
{
return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
{
return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
const char *formatError(DWORD res)
{
static char buf[1000], *p;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, res,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
buf, 1000, NULL);
p = buf+strlen(buf) -1;
if(*p == '\n') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '\r') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '.') *p = '\0';
return buf;
}
void R_UTF8fixslash(char *s); /* from main/util.c */
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, paths = CAR(args), el, slash;
int i, n = LENGTH(paths), res;
char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2;
wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
int mustWork, fslash = 0;
checkArity(op, args);
if(!isString(paths))
errorcall(call, _("'path' must be a character vector"));
slash = CADR(args);
if(!isString(slash) || LENGTH(slash) != 1)
errorcall(call, "'winslash' must be a character string");
const char *sl = CHAR(STRING_ELT(slash, 0));
if (strcmp(sl, "/") && strcmp(sl, "\\"))
errorcall(call, "'winslash' must be '/' or '\\\\'");
if (strcmp(sl, "/") == 0) fslash = 1;
mustWork = asLogical(CADDR(args));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
int warn = 0;
SEXP result;
el = STRING_ELT(paths, i);
result = el;
if(getCharCE(el) == CE_UTF8) {
if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768,
wtmp, &wtmp2)) && res <= 32768) {
if ((res = GetLongPathNameW(wtmp, wlongpath, 32768))
&& res <= 32768) {
wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1);
if(fslash) R_UTF8fixslash(longpath);
result = mkCharCE(longpath, CE_UTF8);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
if(fslash) R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateCharUTF8(el));
R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%ls\": %s", i+1,
filenameToWchar(el,FALSE),
formatError(GetLastError()));
} else {
if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2))
&& res <= MAX_PATH) {
if ((res = GetLongPathName(tmp, longpath, MAX_PATH))
&& res <= MAX_PATH) {
if(fslash) R_fixslash(longpath);
result = mkChar(longpath);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if(fslash) R_fixslash(tmp);
result = mkChar(tmp);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateChar(el));
R_fixslash(tmp);
result = mkChar(tmp);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
}
SET_STRING_ELT(ans, i, result);
}
UNPROTECT(1);
return ans;
}
Obj defVal(Obj expr) { return CADDR(expr); }
