static SCM
expand_let (SCM expr, SCM env)
{
SCM bindings;
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
bindings = CAR (cdr_expr);
if (scm_is_symbol (bindings))
{
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
return expand_named_let (expr, env);
}
check_bindings (bindings, expr);
if (scm_is_null (bindings))
return expand_sequence (CDDR (expr), env);
else
{
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr),
expand_env_extend (env, var_names,
var_syms)));
}
}
// Loops through all the sexps and finds the sender of the specified message. This assumes there is only one possible
// sender of the message, which is probably nearly always true (especially for voice-acted missions).
char *VoiceActingManager::get_message_sender(char *message)
{
int i;
for (i = 0; i < Num_sexp_nodes; i++)
{
if (Sexp_nodes[i].type == SEXP_NOT_USED)
continue;
// stuff
int op = get_operator_const(Sexp_nodes[i].text);
int n = CDR(i);
// find the message sexps
if (op == OP_SEND_MESSAGE)
{
// the first argument is the sender; the third is the message
if (!strcmp(message, Sexp_nodes[CDDR(n)].text))
return Sexp_nodes[n].text;
}
else if (op == OP_SEND_MESSAGE_LIST)
{
// check the argument list
while (n != -1)
{
// as before
if (!strcmp(message, Sexp_nodes[CDDR(n)].text))
return Sexp_nodes[n].text;
// iterate along the list
n = CDDDDR(n);
}
}
else if (op == OP_SEND_RANDOM_MESSAGE)
{
// as before, sort of
char *sender = Sexp_nodes[n].text;
// check the argument list
n = CDDR(n);
while (n != -1)
{
if (!strcmp(message, Sexp_nodes[n].text))
return sender;
// iterate along the list
n = CDR(n);
}
}
else if (op == OP_TRAINING_MSG)
{
// just check the message
if (!strcmp(message, Sexp_nodes[n].text))
return "Training Message";
}
}
return "<none>";
}
elem XmlRpc_DecodeMember(elem obj, elem mem)
{
elem t, x;
elem cur;
elem var, val;
t=MISC_NULL;
cur=CDDR(mem);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("name"))
{
var=SYM(ELEM_TOSTRING(CADDR(CAR(cur))));
}
if(CAAR(cur)==SYM("value"))
{
val=XmlRpc_DecodeValue(CADDR(CAR(cur)));
}
cur=CDR(cur);
}
TyObj_SetSlot(obj, var, val);
return(t);
}
SEXP setOption(SEXP tag, SEXP value)
{
SEXP opt, old, t;
t = opt = SYMVALUE(Rf_install(".Options"));
if (!Rf_isList(opt))
Rf_error("corrupted options list");
opt = FindTaggedItem(opt, tag);
/* The option is being removed. */
if (value == R_NilValue) {
for ( ; t != R_NilValue ; t = CDR(t))
if (TAG(CDR(t)) == tag) {
old = CAR(t);
SETCDR(t, CDDR(t));
return old;
}
return R_NilValue;
}
/* If the option is new, a new slot */
/* is added to the end of .Options */
if (opt == R_NilValue) {
while (CDR(t) != R_NilValue)
t = CDR(t);
PROTECT(value);
SETCDR(t, Rf_allocList(1));
UNPROTECT(1);
opt = CDR(t);
SET_TAG(opt, tag);
}
old = CAR(opt);
SETCAR(opt, value);
return old;
}
static void cell_write(SExp s, int b_escape, struct StreamBase* strm) {
// 省略表示系のチェック
if (consp(CDR(s)) && nullp(CDDR(s))) {
SExp t = CAR(s);
const char* str = NULL;
if (eq(t, intern("quote"))) {
str = "'";
} else if (eq(t, intern("quasiquote"))) {
str = "`";
}
if (str != NULL) {
strm_puts(strm, str, 0);
swrite(CADR(s), b_escape, strm);
return;
}
}
{
int first = TRUE;
SExp p;
strm_puts(strm, "(", 0);
for (p = s; consp(p); p = CDR(p)) {
if (!first) strm_puts(strm, " ", 0);
first = FALSE;
swrite(CAR(p), b_escape, strm);
}
if (!nullp(p)) {
strm_puts(strm, " . ", 0);
swrite(p, b_escape, strm);
}
strm_puts(strm, ")", 0);
}
}
void
VM::backtrace_each(printer_t* prt, int n, scm_obj_t note)
{
assert(PAIRP(note));
if (n < 10) prt->byte(' ');
if (CDR(note) == scm_nil) {
// (expr) : dynamic
prt->format(" %d ~u", n, CAR(note));
} else if (FIXNUMP(CDR(note))) {
// (path . fixnum) : load
assert(STRINGP(CAR(note)));
scm_string_t string = (scm_string_t)CAR(note);
int comment = FIXNUM(CDR(note));
int line = comment / MAX_SOURCE_COLUMN;
int column = comment % MAX_SOURCE_COLUMN;
scm_obj_t expr = backtrace_fetch(string->name, line, column);
if (expr == scm_unspecified) {
prt->format(" %d --- unknown ---", n);
} else {
prt->format(" %d ~u", n, expr);
}
prt->format("~% ...~s line %d", string, line);
} else {
// (expr path . fixnum) : repl
scm_string_t string = (scm_string_t)CADR(note);
int comment = FIXNUM(CDDR(note));
int line = comment / MAX_SOURCE_COLUMN;
prt->format(" %d ~u", n, CAR(note));
prt->format("~% ...~s line %d", string, line);
}
prt->format("~%");
}
/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, arg1, arg2;
int argc;
if (args == R_NilValue)
argc = 0;
else if (CDR(args) == R_NilValue)
argc = 1;
else if (CDDR(args) == R_NilValue)
argc = 2;
else
argc = length(args);
arg1 = CAR(args);
arg2 = CADR(args);
if (ATTRIB(arg1) != R_NilValue || ATTRIB(arg2) != R_NilValue) {
if (DispatchGroup("Ops",call, op, args, env, &ans))
return ans;
}
else if (argc == 1 && IS_SCALAR(arg1, LGLSXP)) {
/* directly handle '!' operator for simple logical scalars. */
int v = LOGICAL(arg1)[0];
return ScalarLogical(v == NA_LOGICAL ? v : ! v);
}
if (argc == 1)
return lunary(call, op, arg1);
else if (argc == 2)
return lbinary(call, op, args);
else
error(_("binary operations require two arguments"));
return R_NilValue; /* for -Wall */
}
static SCM
expand_case_lambda_star (SCM expr, SCM env)
{
ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
return LAMBDA (scm_source_properties (expr),
SCM_EOL,
expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
}
static SCM
expand_letstar (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
return expand_letstar_clause (CADR (expr), CDDR (expr), env);
}
/*
Helper fun for `attr(dimnames(), x)`
Returns wrap object, length 2 VECSXP containing wrap call and pointer
to element to substiute
*/
SEXP ALIKEC_compare_dimnames_wrap(const char * name) {
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(
wrap, 0, lang3(
ALIKEC_SYM_attr, lang2(R_DimNamesSymbol, R_NilValue),
mkString(name)
) );
SET_VECTOR_ELT(wrap, 1, CDDR(VECTOR_ELT(wrap, 0)));
UNPROTECT(1);
return(wrap);
}
static SCM
expand_eval_when (SCM expr, SCM env)
{
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
|| scm_is_true (scm_memq (sym_load, CADR (expr))))
return expand_sequence (CDDR (expr), env);
else
return VOID (scm_source_properties (expr));
}
Obj transformSugarDef(Obj expr) {
Obj funcArgs = CADR(expr);
Obj func = CAR(funcArgs);
Obj args = CDR(funcArgs);
Obj body = CDDR(expr);
Obj lambdaExpr = CONS(LAMBDAOBJ, CONS(args, body));
Obj transformed = CONS(DEFOBJ, CONS(func, CONS(lambdaExpr, NULLOBJ)));
return transformed;
}
SEXP RKStructureGetter::callSimpleFun2 (SEXP fun, SEXP arg1, SEXP arg2, SEXP env) {
SEXP call = allocVector (LANGSXP, 3);
PROTECT (call);
SETCAR (call, fun);
SETCAR (CDR (call), arg1);
SETCAR (CDDR (call), arg2);
SEXP ret = eval (call, env);
UNPROTECT (1); /* call */
return ret;
}
/* internal API - takes one mandatory argument (object to inspect) and
two optional arguments (deep and pvec - see above), positional argument
matching only */
SEXP attribute_hidden do_inspect(SEXP call, SEXP op, SEXP args, SEXP env) {
SEXP obj = CAR(args);
int deep = -1;
int pvec = 5;
if (CDR(args) != R_NilValue) {
deep = asInteger(CADR(args));
if (CDDR(args) != R_NilValue)
pvec = asInteger(CADDR(args));
}
inspect_tree(0, CAR(args), deep, pvec);
return obj;
}
elem XmlRpc_HandleCall(elem req)
{
elem cur, t;
elem method, params;
method=MISC_NULL;
params=MISC_EOL;
if(CAR(req)==SYM("methodCall"))
{
cur=CDDR(req);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("methodName"))
{
method=CADDR(CAR(cur));
}
if(CAAR(cur)==SYM("params"))
{
t=CDDR(CAR(cur));
params=XmlRpc_DecodeParams(t);
}
cur=CDR(cur);
}
}
kprint("method call: ");
TyFcn_DumpElem(method);
kprint(" with: ");
TyFcn_DumpElemBR(params);
method=SYM(ELEM_TOSTRING(method));
t=Verify_Func(method, params);
// t=MISC_NULL;
return(t);
}
Result* firstlast_prototype(SEXP call, const ILazySubsets& subsets, int nargs, int pos) {
SEXP tail = CDDR(call);
SETCAR(call, Rf_install("nth"));
Pairlist p(pos);
if (Rf_isNull(tail)) {
SETCDR(CDR(call), p);
} else {
SETCDR(p, tail);
SETCDR(CDR(call), p);
}
Result* res = nth_prototype(call, subsets, nargs + 1);
return res;
}
uptr_t loop(uptr_t *env, uptr_t form) {
uptr_t *bindings_p = refer(CAR(form)),
*body_p = refer(CDR(form)),
*form_p = refer(form),
*local_env = refer(*env);
while (*bindings_p) {
assoc(local_env, CAR(*bindings_p), eval(local_env, CADR(*bindings_p)));
*bindings_p = CDDR(*bindings_p);
}
// print_env(local_env);
uptr_t rval = NIL,
*new_env = refer(NIL),
*new_vals = refer(NIL);
while (*body_p) {
rval = eval(local_env, CAR(*body_p));
*body_p = CDR(*body_p);
if (IS_CONS(rval) && IS_SYM(CAR(rval)) && SVAL(CAR(rval)) == S_RECUR) {
*new_env = *env;
*new_vals = CDR(rval);
*bindings_p = CAR(*form_p);
while (*new_vals && *bindings_p) {
assoc(new_env, CAR(*bindings_p), eval(local_env, CAR(*new_vals)));
*bindings_p = CDDR(*bindings_p);
*new_vals = CDR(*new_vals);
}
*body_p = CDR(*form_p);
*local_env = *new_env;
}
}
release(6); // bindings_p, body_p, form_p, local_env, new_env, new_vals
return rval;
}
elem XmlRpc_DecodeStruct(elem str)
{
elem t, x;
elem cur;
t=TyObj_CloneNull();
cur=CDDR(str);
while(ELEM_CONSP(cur))
{
XmlRpc_DecodeMember(t, CAR(cur));
cur=CDR(cur);
}
return(t);
}
elem XmlRpc_DecodeArray(elem str)
{
elem t, x;
elem cur;
t=MISC_EOL;
cur=CDDR(str);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("data"))
{
t=XmlRpc_DecodeArraySlots(CAR(cur));
}
cur=CDR(cur);
}
return(t);
}
elem XmlRpc_DecodeParam(elem param)
{
elem t, x;
elem cur;
t=MISC_NULL;
cur=CDDR(param);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("value"))
{
t=XmlRpc_DecodeValue(CADDR(CAR(cur)));
}
cur=CDR(cur);
}
return(t);
}
elem XmlRpc_DecodeArraySlots(elem param)
{
elem t, x;
elem cur;
x=MISC_EOL;
cur=CDDR(param);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("value"))
{
t=XmlRpc_DecodeValue(CADDR(CAR(cur)));
x=CONS(t, x);
}
cur=CDR(cur);
}
x=TyFcn_NReverse(x);
return(x);
}
uptr_t let(uptr_t *env, uptr_t args) {
uptr_t *bindings_p = refer(CAR(args)),
*body_p = refer(CDR(args)),
*local_env = refer(*env);
while (*bindings_p) {
assoc(local_env, CAR(*bindings_p), eval(local_env, CADR(*bindings_p)));
*bindings_p = CDDR(*bindings_p);
}
uptr_t rval = NIL;
while(*body_p) {
rval = eval(local_env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(3); // bindings_p, body_p, local_env
return rval;
}
uptr_t _fn(uptr_t *env, uptr_t fn, uptr_t args) {
uptr_t *lvars_p = refer(CADR(fn)),
*body_p = refer(CDDR(fn)),
*args_p = refer(args),
*local_env = refer(*env);
while (*lvars_p && *args_p) {
assoc(local_env, CAR(*lvars_p), CAR(*args_p));
*lvars_p = CDR(*lvars_p);
*args_p = CDR(*args_p);
}
uptr_t rval = NIL;
while(*body_p) {
rval = eval(local_env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(4); // lvars_p, body_p, args_p, local_env
return rval;
}
static SCM
expand_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (expand (CAR (binding), env), fluids);
vals = scm_cons (expand (CADR (binding), env), vals);
}
return DYNLET (scm_source_properties (expr),
scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
expand_sequence (CDDR (expr), env));
}
// Evaluator
SEXP Rcpp_eval__impl(SEXP expr_, SEXP env) {
RCPP_DEBUG( "Rcpp_eval( expr = <%p>, env = <%p> )", expr_, env )
Scoped<SEXP> expr = expr_ ;
reset_current_error() ;
Environment RCPP = Environment::Rcpp11_namespace();
static SEXP tryCatchSym = NULL, evalqSym, conditionMessageSym, errorRecorderSym, errorSym ;
if (!tryCatchSym) {
tryCatchSym = ::Rf_install("tryCatch");
evalqSym = ::Rf_install("evalq");
conditionMessageSym = ::Rf_install("conditionMessage");
errorRecorderSym = ::Rf_install(".rcpp_error_recorder");
errorSym = ::Rf_install("error");
}
RCPP_DEBUG( " [Rcpp_eval] RCPP = " )
Scoped<SEXP> call = Rf_lang3(
tryCatchSym,
Rf_lang3( evalqSym, expr, env ),
errorRecorderSym
) ;
SET_TAG( CDDR(call), errorSym ) ;
/* call the tryCatch call */
Scoped<SEXP> res = ::Rf_eval( call, RCPP );
if( error_occured() ) {
Scoped<SEXP> current_error = rcpp_get_current_error() ;
Scoped<SEXP> conditionMessageCall = ::Rf_lang2(conditionMessageSym, current_error) ;
Scoped<SEXP> condition_message = ::Rf_eval(conditionMessageCall, R_GlobalEnv) ;
std::string message(CHAR(::Rf_asChar(condition_message)));
throw eval_error(message) ;
}
return res ;
}
int evaluate(int exp_id) {
if (DEBUG) {
print(exp_id);
indent += 1;
}
if (ATOM(exp_id)) {
int found = find_env(exp_id);
if (!NILP(found)) {
expression[exp_id] = REMOVE_BIT(found);
}
} else {
switch (expression[CAR(exp_id)]) {
// car
case 1:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
error(LIST_EXPECTED);
}
expression[exp_id] = expression[CAADR(exp_id)];
break;
// cdr
case 2:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
error(LIST_EXPECTED);
}
expression[exp_id] = expression[CDR(CADR(exp_id))];
break;
// cons
case 3:
evaluate(CADR(exp_id));
evaluate(CADDR(exp_id));
expression[exp_id] = CONS(CADR(exp_id), CADDR(exp_id));
break;
// quote
case 4:
expression[exp_id] = expression[CADR(exp_id)];
break;
// eq
case 5:
evaluate(CADR(exp_id));
evaluate(CADDR(exp_id));
if (expression[CADR(exp_id)] == expression[CADDR(exp_id)]) {
expression[exp_id] = L_T;
} else {
expression[exp_id] = L_NIL;
}
break;
// atom
case 6:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
expression[exp_id] = L_T;
} else {
expression[exp_id] = L_NIL;
}
break;
// cond
case 7:
evaluate_cond(CDR(exp_id));
expression[exp_id] = expression[CDR(exp_id)];
break;
// print
case 8:
evaluate(CADR(exp_id));
print(CADR(exp_id));
expression[exp_id] = expression[CADR(exp_id)];
break;
// apply
case 12:
{
int callee = CADR(exp_id);
int args = CDDR(exp_id);
eval_args(args);
before_call();
// if expression stack is not sufficient,
// you can save and restore max id here
if (expression[CAR(callee)] == L_LAMBDA) {
int new_exp_id = move_exp(CADDR(callee));
update_environment(CADR(callee), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
} else if (expression[CAR(callee)] == L_LABEL) {
int lambda_name = CADR(callee);
int lambda = CADDR(callee);
int new_exp_id = 0;
if (ATOM(lambda_name)) {
env[(call_depth << 8) + expression[lambda_name]] = SET_BIT(expression[lambda]);
} else {
error(INVALID_LABEL_NAME);
}
new_exp_id = move_exp(CADDR(lambda));
update_environment(CADR(lambda), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
} else {
error(NOT_LAMBDA);
}
after_call();
}
break;
default:
{
int found = find_env(CAR(exp_id));
if (!NILP(found)) {
int cdr = (REMOVE_BIT(found) << 16) >> 16;
int new_exp_id = 0;
int args = CDR(exp_id);
eval_args(args);
before_call();
new_exp_id = move_exp(CADR(cdr));
update_environment(CAR(cdr), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
after_call();
} else {
print(exp_id);
error(FUNCTION_NOT_FOUND);
}
}
break;
}
/* Evaluate object
* NULL return value means Nothing
*/
object *eval(object *obj, env_hashtable *env)
{
object *cur, *eobj,
*last_pair, *t,
*ecar, *ecdr;
if (!obj)
return NULL;
/* Detect syntatic construction */
if (TYPE(obj) == OBJ_PAIR &&
TYPE(CAR(obj)) == OBJ_SYMBOL) {
t = CAR(obj);
if (strcmp("lambda", STR(t)) == 0) {
t = CDDR(obj);
t = cons(symbol("begin"), t);
eobj = compound_procedure(CADR(obj), t, env);
return eobj;
} else if (strcmp("define", STR(t)) == 0) {
eobj = eval(CADDR(obj), env);
env_hashtable_insert(env, STR(CADR(obj)), eobj);
return NULL; /* Not error, just nothing */
} else if (strcmp("begin", STR(t)) == 0) {
obj = CDR(obj);
eobj = NULL; /* Not error, just nothing */
while (obj != null_object) {
eobj = eval(CAR(obj), env);
obj = CDR(obj);
}
return eobj;
} else if (strcmp("apply", STR(t)) == 0) {
eobj = eval(CADR(obj), env);
t = eval(CADDR(obj), env);
return apply(eobj, t);
} else if (strcmp("quote", STR(t)) == 0) {
return CADR(obj);
}
}
/* Object evaluation */
switch (TYPE(obj)) {
case OBJ_NUMBER:
case OBJ_BOOLEAN:
return obj;
case OBJ_SYMBOL:
return env_hashtable_find(env, STR(obj));
case OBJ_PAIR:
cur = obj;
eobj = null_object;
last_pair = NULL;
while (cur != null_object &&
TYPE(cur) == OBJ_PAIR) {
t = cons(eval(CAR(cur), env), null_object);
if (!last_pair)
eobj = t;
else
CDR(last_pair) = t;
last_pair = t;
cur = CDR(cur);
}
ecar = CAR(eobj);
ecdr = CDR(eobj);
return apply(ecar, ecdr);
default:
return NULL;
}
}
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) ) ;
}
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
if (!SCM_MEMOIZED_P (x))
abort ();
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env);
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
case SCM_M_DEFINE:
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
scm_dynstack_push_dynwind (&t->dynstack, in, out);
res = eval (CADR (mx), env);
scm_dynstack_pop (&t->dynstack);
scm_call_0 (out);
return res;
}
case SCM_M_WITH_FLUIDS:
{
long i, len;
SCM *fluidv, *valuesv, walk, res;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = EVAL1 (CAR (walk), env);
scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
thread->dynamic_state);
res = eval (CDDR (mx), env);
scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return res;
}
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_call_with_vm (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
int n;
SCM ret;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env);
ret = CAR (env);
if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its
name */
error_used_before_defined ();
return ret;
}
case SCM_M_LEXICAL_SET:
{
int n;
SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
return SCM_UNSPECIFIED;
}
case SCM_M_TOPLEVEL_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
{
while (scm_is_pair (env))
env = CDR (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
return SCM_UNSPECIFIED;
}
else
{
while (scm_is_pair (env))
env = CDR (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val);
return SCM_UNSPECIFIED;
}
}
case SCM_M_MODULE_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, SCM_BOOL_F));
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
case SCM_M_PROMPT:
{
SCM vm, k, res;
scm_i_jmp_buf registers;
/* We need the handler after nonlocal return to the setjmp, so
make sure it is volatile. */
volatile SCM handler;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vm = scm_the_vm ();
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
SCM_VM_DATA (vm)->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
proc = handler;
args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
goto apply_proc;
}
res = eval (CADR (mx), env);
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
/* 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;
}
