T eval_if(T form, Environment env) {
if (!NILP(eval(CADR(form), env))) {
return eval(CADDR(form), env);
} else {
return eval(CADDDR(form), env);
}
}
/* .Internal(identical(..)) */
SEXP attribute_hidden do_identical(SEXP call, SEXP op, SEXP args, SEXP env)
{
int num_eq = 1, single_NA = 1, attr_as_set = 1, ignore_bytecode = 1, nargs = length(args), flags;
/* avoid problems with earlier (and future) versions captured in S4 methods */
/* checkArity(op, args); */
if (nargs < 5)
error("%d arguments passed to .Internal(%s) which requires %d",
length(args), PRIMNAME(op), PRIMARITY(op));
if (nargs >= 5) {
num_eq = asLogical(CADDR(args));
single_NA = asLogical(CADDDR(args));
attr_as_set = asLogical(CAD4R(args));
}
if (nargs >= 6)
ignore_bytecode = asLogical(CAD4R(CDR(args)));
if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");
if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");
if(attr_as_set == NA_LOGICAL) error(_("invalid '%s' value"), "attrib.as.set");
if(ignore_bytecode == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.bytecode");
flags = (num_eq ? 0 : 1) + (single_NA ? 0 : 2) + (attr_as_set ? 0 : 4) + (ignore_bytecode ? 0 : 8);
return ScalarLogical(R_compute_identical(CAR(args), CADR(args), flags));
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
int nargs = length(args);
#ifdef R_version_3_4_or_so
checkArity(op, args);
#else
// will work also for code byte-compiled *before* 'keepNA' was introduced
if (nargs < 3 || nargs > 4)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 3, 4);
#endif
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()");
R_xlen_t len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
const char *type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
size_t ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
nchar_type type_;
if (strncmp(type, "bytes", ntype) == 0) type_ = Bytes;
else if (strncmp(type, "chars", ntype) == 0) type_ = Chars;
else if (strncmp(type, "width", ntype) == 0) type_ = Width;
else error(_("invalid '%s' argument"), "type");
int allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
int keepNA;
if(nargs >= 4) {
keepNA = asLogical(CADDDR(args));
if (keepNA == NA_LOGICAL) // default
keepNA = (type_ == Width) ? FALSE : TRUE;
} else keepNA = FALSE; // default
PROTECT(s = allocVector(INTSXP, len));
int *s_ = INTEGER(s);
for (R_xlen_t i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
char msg_i[20]; sprintf(msg_i, "element %ld", (long)i+1);
s_[i] = R_nchar(sxi, type_, allowNA, keepNA, msg_i);
}
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;
}
struct lispobj *apply(struct lispobj *proc, struct lispobj *args)
{
if(proc != NULL && OBJ_TYPE(proc) == CONS) {
struct lispobj *ret;
if(NEW_SYMBOL("SUBR") == CAR(proc)) {
/* Apply primitive function. */
struct lispobj *body, *(*subr)(struct lispobj *);
body = CADR(proc);
subr = (struct lispobj *) NUMBER_VALUE(body);
//subr = (struct lispobj *) body;
ret = heap_grab(subr(args));
} else if(NEW_SYMBOL("PROC") == CAR(proc)) {
/* Apply user defined procedure. */
struct lispobj *body, *params, *penv;
body = CADDR(proc);
params = CADR(proc);
penv = CADDDR(proc);
if(length(params) == length(args)) {
struct lispobj *env;
if(params == NULL || params == NEW_SYMBOL("NIL")) {
env = penv;
ret = eval_progn(body, env);
} else {
env = heap_grab(NEW_CONS(env_frame_make(params, args), penv));
ret = eval_progn(body, env);
heap_release(env);
}
} else {
char error[64];
snprintf(error,
64,
"Has recieved wrong number of parameters: %d.\n",
length(args));
ret = heap_grab(NEW_ERROR(error));
}
} else {
goto error;
}
return ret;
}
error:
return heap_grab(NEW_ERROR("Unknown procedure.\n"));
}
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)));
}
SEXP mrb4R_set_iv(SEXP args) {
SEXP vect;
mrb_value rbobj,rbval;
char *var;
if(!inherits(CADR(args),"rbObj")) error("invalid first argument");
rbobj=*((mrb_value*) R_ExternalPtrAddr(CADR(args)));
if(!isValidString(CADDR(args))) error("invalid second argument");
var = (char*)CHAR(STRING_ELT(CADDR(args), 0));
vect=CADDDR(args);
rbval=(mrb_value)RVector2mrbArray(vect);
mrb_iv_set(mrb,rbobj,mrb_intern_cstr(mrb,var),rbval);
return R_NilValue;
}
SEXP attribute_hidden do_dynload(SEXP call, SEXP op, SEXP args, SEXP env)
{
char buf[2 * PATH_MAX];
DllInfo *info;
checkArity(op,args);
if (!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("character argument expected"));
GetFullDLLPath(call, buf, translateChar(STRING_ELT(CAR(args), 0)));
/* AddDLL does this DeleteDLL(buf); */
info = AddDLL(buf, LOGICAL(CADR(args))[0], LOGICAL(CADDR(args))[0],
translateChar(STRING_ELT(CADDDR(args), 0)));
if(!info)
error(_("unable to load shared object '%s':\n %s"), buf, DLLerror);
return(Rf_MakeDLLInfo(info));
}
SEXP RTcl_SetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *value;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
value = (Tcl_Obj *) R_ExternalPtrAddr(CADDDR(args));
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
Tcl_SetVar2Ex(RTcl_interp, xstr, istr, value, 0);
vmaxset(vmax);
return R_NilValue;
}
SEXP arrangeWindows(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP windows;
int action, preserve, outer;
args = CDR(args);
windows = CAR(args);
if (length(windows)) {
if (TYPEOF(windows) != VECSXP) error(_("'%s' must be a list"), "windows");
void **handles = (void **) R_alloc(length(windows), sizeof(void *));
for (int i = 0; i < length(windows); i++) {
if (TYPEOF(VECTOR_ELT(windows, i)) != EXTPTRSXP)
error(_("'%s' element %d is not a window handle"), "windows", i+1);
handles[i] = R_ExternalPtrAddr(VECTOR_ELT(windows, i));
}
action = asInteger(CADR(args));
preserve = asInteger(CADDR(args));
outer = asInteger(CADDDR(args));
in_ArrangeWindows(length(windows), handles, action, preserve, outer);
}
return windows;
}
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;
}
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);
}
SEXP numeric_deriv(SEXP args)
{
SEXP theta, expr, rho, ans, ans1, gradient, par, dimnames;
double tt, xx, delta, eps = sqrt(DOUBLE_EPS);
int start, i, j;
expr = CADR(args);
if(!isString(theta = CADDR(args)))
error("theta should be of type character");
if(!isEnvironment(rho = CADDDR(args)))
error("rho should be an environment");
PROTECT(ans = coerceVector(eval(expr, rho), REALSXP));
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), LENGTH(theta)));
for(i = 0, start = 0; i < LENGTH(theta); i++, start += LENGTH(ans)) {
PROTECT(par = findVar(install(CHAR(STRING_ELT(theta, i))), rho));
tt = REAL(par)[0];
xx = fabs(tt);
delta = (xx < 1) ? eps : xx*eps;
REAL(par)[0] += delta;
PROTECT(ans1 = coerceVector(eval(expr, rho), REALSXP));
for(j = 0; j < LENGTH(ans); j++)
REAL(gradient)[j + start] =
(REAL(ans1)[j] - REAL(ans)[j])/delta;
REAL(par)[0] = tt;
UNPROTECT(2); /* par, ans1 */
}
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 1, theta);
dimnamesgets(gradient, dimnames);
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(3); /* ans gradient dimnames */
return ans;
}
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;
}
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
* ------- but also called from ./eval.c */
SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *saveToplevelContext;
RCNTXT *saveGlobalContext;
RCNTXT thiscontext, returncontext, *cptr;
int savestack, browselevel;
SEXP ap, topExp, argList;
/* argument matching */
PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("text"));
SET_TAG(CDR(ap), install("condition"));
SET_TAG(CDDR(ap), install("expr"));
SET_TAG(CDDDR(ap), install("skipCalls"));
argList = matchArgs(ap, args, call);
UNPROTECT(1);
PROTECT(argList);
/* substitute defaults */
if(CAR(argList) == R_MissingArg)
SETCAR(argList, mkString(""));
if(CADR(argList) == R_MissingArg)
SETCAR(CDR(argList), R_NilValue);
if(CADDR(argList) == R_MissingArg)
SETCAR(CDDR(argList), ScalarLogical(1));
if(CADDDR(argList) == R_MissingArg)
SETCAR(CDDDR(argList), ScalarInteger(0));
/* return if 'expr' is not TRUE */
if( !asLogical(CADDR(argList)) ) {
UNPROTECT(1);
return R_NilValue;
}
/* Save the evaluator state information */
/* so that it can be restored on exit. */
browselevel = countContexts(CTXT_BROWSER, 1);
savestack = R_PPStackTop;
PROTECT(topExp = R_CurrentExpr);
saveToplevelContext = R_ToplevelContext;
saveGlobalContext = R_GlobalContext;
if (!RDEBUG(rho)) {
int skipCalls = asInteger(CADDDR(argList));
cptr = R_GlobalContext;
while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--)
&& cptr->callflag )
cptr = cptr->nextcontext;
Rprintf("Called from: ");
int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv));
if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp;
if( cptr != R_ToplevelContext ) {
PrintValueRec(cptr->call, rho);
SET_RDEBUG(cptr->cloenv, 1);
} else
Rprintf("top level \n");
R_BrowseLines = 0;
}
R_ReturnedValue = R_NilValue;
/* Here we establish two contexts. The first */
/* of these provides a target for return */
/* statements which a user might type at the */
/* browser prompt. The (optional) second one */
/* acts as a target for error returns. */
begincontext(&returncontext, CTXT_BROWSER, call, rho,
R_BaseEnv, argList, R_NilValue);
if (!SETJMP(returncontext.cjmpbuf)) {
begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
R_BaseEnv, R_NilValue, R_NilValue);
if (SETJMP(thiscontext.cjmpbuf)) {
SET_RESTART_BIT_ON(thiscontext.callflag);
R_ReturnedValue = R_NilValue;
R_Visible = FALSE;
}
R_GlobalContext = &thiscontext;
R_InsertRestartHandlers(&thiscontext, TRUE);
R_ReplConsole(rho, savestack, browselevel+1);
endcontext(&thiscontext);
}
endcontext(&returncontext);
/* Reset the interpreter state. */
R_CurrentExpr = topExp;
UNPROTECT(1);
R_PPStackTop = savestack;
UNPROTECT(1);
R_CurrentExpr = topExp;
R_ToplevelContext = saveToplevelContext;
R_GlobalContext = saveGlobalContext;
return R_ReturnedValue;
}
Obj funcEnv(Obj obj) {
return CADDDR(GETLIST(obj));
}
void eval(BOOLEAN do_gc)
{
static unsigned int count = 0;
OBJECT_PTR exp = car(reg_next_expression);
OBJECT_PTR opcode = car(exp);
pin_globals();
if(do_gc)
{
count++;
if(count == GC_FREQUENCY)
{
gc(false, true);
count = 0;
}
}
if(opcode == APPLY && profiling_in_progress)
{
last_operator = reg_accumulator;
if(prev_operator != NIL)
{
OBJECT_PTR operator_to_be_used;
hashtable_entry_t *e;
unsigned int count;
unsigned int mem_alloc;
double elapsed_wall_time;
double elapsed_cpu_time;
double temp1 = get_wall_time();
clock_t temp2 = clock();
unsigned int temp3 = memory_allocated();
profiling_datum_t *pd = (profiling_datum_t *)malloc(sizeof(profiling_datum_t));
if(IS_SYMBOL_OBJECT(prev_operator))
operator_to_be_used = prev_operator;
else
{
OBJECT_PTR res = get_symbol_from_value(prev_operator, reg_current_env);
if(car(res) != NIL)
operator_to_be_used = cdr(res);
else
operator_to_be_used = cons(LAMBDA,
cons(get_params_object(prev_operator),
cons(car(get_source_object(prev_operator)), NIL)));
}
e = hashtable_get(profiling_tab, (void *)operator_to_be_used);
if(e)
{
profiling_datum_t *pd = (profiling_datum_t *)e->value;
count = pd->count + 1;
elapsed_wall_time = pd->elapsed_wall_time + temp1 - wall_time_var;
elapsed_cpu_time = pd->elapsed_cpu_time + (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = pd->mem_allocated + temp3 - mem_alloc_var;
hashtable_remove(profiling_tab, (void *)operator_to_be_used);
free(pd);
}
else
{
count = 1;
elapsed_wall_time = temp1 - wall_time_var;
elapsed_cpu_time = (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = temp3 - mem_alloc_var;
}
pd->count = count;
pd->elapsed_wall_time = elapsed_wall_time;
pd->elapsed_cpu_time = elapsed_cpu_time;
pd->mem_allocated = mem_alloc;
hashtable_put(profiling_tab, (void *)operator_to_be_used, (void *)pd);
}
wall_time_var = get_wall_time();
cpu_time_var = clock();
mem_alloc_var = memory_allocated();
prev_operator = reg_accumulator;
}
if(opcode == HALT)
{
halt_op();
}
else if(opcode == REFER)
{
if(refer(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONSTANT)
{
if(constant(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CLOSE)
{
if(closure(exp))
return;
reg_next_expression = fifth(exp);
}
else if(opcode == MACRO)
{
if(macro(exp))
return;
reg_next_expression = CADDDDR(exp);
}
else if(opcode == TEST)
{
if(reg_accumulator != NIL)
reg_next_expression = CADR(exp);
else
reg_next_expression = CADDR(exp);
}
//Not using this WHILE; reverting
//to macro definition, as this
//version doesn't handle (BREAK)
else if(opcode == WHILE)
{
OBJECT_PTR cond = CADR(exp);
OBJECT_PTR body = CADDR(exp);
OBJECT_PTR ret = NIL;
while(1)
{
OBJECT_PTR temp = reg_current_stack;
reg_next_expression = cond;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
if(reg_accumulator == NIL)
break;
reg_next_expression = body;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
//to handle premature exits
//via RETURN-FROM
if(reg_current_stack != temp)
return;
ret = reg_accumulator;
}
reg_accumulator = ret;
reg_next_expression = CADDDR(exp);
}
else if(opcode == ASSIGN)
{
if(assign(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == DEFINE)
{
if(define(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONTI)
{
if(conti())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == NUATE) //this never gets called
{
reg_current_stack = CADR(exp);
reg_accumulator = CADDR(exp);
reg_current_value_rib = NIL;
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
}
else if(opcode == FRAME)
{
if(frame(exp))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == ARGUMENT)
{
if(argument())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == APPLY)
{
apply_compiled();
}
else if(opcode == RETURN)
{
return_op();
}
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* 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(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++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = int( n); // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
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;
}
Obj ifElse(Obj expr) {
return CADDDR(GETLIST(expr));
}
SEXP actuar_do_panjer(SEXP args)
{
SEXP p0, p1, fs0, sfx, a, b, conv, tol, maxit, echo, sfs;
double *fs, *fx, cumul;
int upper, m, k, n, x = 1;
double norm; /* normalizing constant */
double term; /* constant in the (a, b, 1) case */
/* The length of vector fs is not known in advance. We opt for a
* simple scheme: allocate memory for a vector of size 'size',
* double the size when the vector is full. */
int size = INITSIZE;
fs = (double *) S_alloc(size, sizeof(double));
/* All values received from R are then protected. */
PROTECT(p0 = coerceVector(CADR(args), REALSXP));
PROTECT(p1 = coerceVector(CADDR(args), REALSXP));
PROTECT(fs0 = coerceVector(CADDDR(args), REALSXP));
PROTECT(sfx = coerceVector(CAD4R(args), REALSXP));
PROTECT(a = coerceVector(CAD5R(args), REALSXP));
PROTECT(b = coerceVector(CAD6R(args), REALSXP));
PROTECT(conv = coerceVector(CAD7R(args), INTSXP));
PROTECT(tol = coerceVector(CAD8R(args), REALSXP));
PROTECT(maxit = coerceVector(CAD9R(args), INTSXP));
PROTECT(echo = coerceVector(CAD10R(args), LGLSXP));
/* Initialization of some variables */
fx = REAL(sfx); /* severity distribution */
upper = length(sfx) - 1; /* severity distribution support upper bound */
fs[0] = REAL(fs0)[0]; /* value of Pr[S = 0] (computed in R) */
cumul = REAL(fs0)[0]; /* cumulative probability computed */
norm = 1 - REAL(a)[0] * fx[0]; /* normalizing constant */
n = INTEGER(conv)[0]; /* number of convolutions to do */
/* If printing of recursions was asked for, start by printing a
* header and the probability at 0. */
if (LOGICAL(echo)[0])
Rprintf("x\tPr[S = x]\tCumulative probability\n%d\t%.8g\t%.8g\n",
0, fs[0], fs[0]);
/* (a, b, 0) case (if p0 is NULL) */
if (isNull(CADR(args)))
do
{
/* Stop after 'maxit' recursions and issue warning. */
if (x > INTEGER(maxit)[0])
{
warning(_("maximum number of recursions reached before the probability distribution was complete"));
break;
}
/* If fs is too small, double its size */
if (x >= size)
{
fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
size = size << 1;
}
m = x;
if (x > upper) m = upper; /* upper bound of the sum */
/* Compute probability up to the scaling constant */
for (k = 1; k <= m; k++)
fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
fs[x] = fs[x]/norm; /* normalization */
cumul += fs[x]; /* cumulative sum */
if (LOGICAL(echo)[0])
Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);
x++;
} while (cumul < REAL(tol)[0]);
/* (a, b, 1) case (if p0 is non-NULL) */
else
{
/* In the (a, b, 1) case, the recursion formula has an
* additional term involving f_X(x). The mathematical notation
* assumes that f_X(x) = 0 for x > m (the maximal value of the
* distribution). We need to treat this specifically in
* programming, though. */
double fxm;
/* Constant term in the (a, b, 1) case. */
term = (REAL(p1)[0] - (REAL(a)[0] + REAL(b)[0]) * REAL(p0)[0]);
do
{
/* Stop after 'maxit' recursions and issue warning. */
if (x > INTEGER(maxit)[0])
{
warning(_("maximum number of recursions reached before the probability distribution was complete"));
break;
}
if (x >= size)
{
fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
size = size << 1;
}
m = x;
if (x > upper)
{
m = upper; /* upper bound of the sum */
fxm = 0.0; /* i.e. no additional term */
}
else
fxm = fx[m]; /* i.e. additional term */
for (k = 1; k <= m; k++)
fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
fs[x] = (fs[x] + fxm * term) / norm;
cumul += fs[x];
if (LOGICAL(echo)[0])
Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);
x++;
} while (cumul < REAL(tol)[0]);
}
/* If needed, convolve the distribution obtained above with itself
* using a very simple direct technique. Since we want to
* continue storing the distribution in array 'fs', we need to
* copy the vector in an auxiliary array at each convolution. */
if (n)
{
int i, j, ox;
double *ofs; /* auxiliary array */
/* Resize 'fs' to its final size after 'n' convolutions. Each
* convolution increases the length from 'x' to '2 * x - 1'. */
fs = (double *) S_realloc((char *) fs, (1 << n) * (x - 1) + 1, size, sizeof(double));
/* Allocate enough memory in the auxiliary array for the 'n'
* convolutions. This is just slightly over half the final
* size of 'fs'. */
ofs = (double *) S_alloc((1 << (n - 1)) * (x - 1) + 1, sizeof(double));
for (k = 0; k < n; k++)
{
memcpy(ofs, fs, x * sizeof(double)); /* keep previous array */
ox = x; /* previous array length */
x = (x << 1) - 1; /* new array length */
for(i = 0; i < x; i++)
fs[i] = 0.0;
for(i = 0; i < ox; i++)
for(j = 0; j < ox; j++)
fs[i + j] += ofs[i] * ofs[j];
}
}
/* Copy the values of fs to a SEXP which will be returned to R. */
PROTECT(sfs = allocVector(REALSXP, x));
memcpy(REAL(sfs), fs, x * sizeof(double));
UNPROTECT(11);
return(sfs);
}
T eval_defun(T form, Environment env) {
Object name = CADR(form);
Object value = mklambda(CADDR(form), CADDDR(form), env);
defglobal(name, value);
return name;
}
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;
}
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;
}
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;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; /* initialize to avoid a warning */
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = n > INT_MAX;
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
// check once here
if (commonType != CPLXSXP && commonType != REALSXP &&
commonType != INTSXP && commonType != LGLSXP &&
commonType != RAWSXP && commonType != STRSXP &&
commonType != VECSXP)
error(_("type '%s' is not supported"), type2char(commonType));
dim_v = getAttrib(value, R_DimSymbol);
array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1);
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* 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>]], ...) */
SEXP isym = install("i");
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
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 */
PROTECT(tmp = LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
int common_len_offset = 0;
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
val = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(val))
val = lazy_duplicate(val); // Need to duplicate? Copying again anyway
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
Rboolean okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
// two cases - only for efficiency
if(commonLen == 1) { // common case
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break;
case REALSXP: REAL(ans) [i] = REAL (val)[0]; break;
case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break;
case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break;
case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break;
case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break;
case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break;
}
} else { // commonLen > 1 (typically, or == 0) :
switch (commonType) {
case REALSXP:
memcpy(REAL(ans) + common_len_offset,
REAL(val), commonLen * sizeof(double)); break;
case INTSXP:
memcpy(INTEGER(ans) + common_len_offset,
INTEGER(val), commonLen * sizeof(int)); break;
case LGLSXP:
memcpy(LOGICAL(ans) + common_len_offset,
LOGICAL(val), commonLen * sizeof(int)); break;
case RAWSXP:
memcpy(RAW(ans) + common_len_offset,
RAW(val), commonLen * sizeof(Rbyte)); break;
case CPLXSXP:
memcpy(COMPLEX(ans) + common_len_offset,
COMPLEX(val), commonLen * sizeof(Rcomplex)); break;
case STRSXP:
for (int j = 0; j < commonLen; j++)
SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j));
break;
case VECSXP:
for (int j = 0; j < commonLen; j++)
SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j));
break;
}
common_len_offset += commonLen;
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = (int) n; // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
Obj ifElse(Obj expr) { return CADDDR(expr); }
