int prn_func_macr(Obj a, Obj stream, char* which){ Obj env = CADR(a); Obj args = CADDR(a); Obj body = CDDDR(a); writestr(stream, "("); writestr(stream, which); writestr(stream, " "); prnobj( args, stream, 1); writestr(stream, " "); a = body; while( NNULLP( a )){ if( NCONSP( a )){ writestr(stream, " . "); prnobj(a, stream, 1); break; } writestr(stream, " "); prnobj( CAR(a), stream, 1); a = CDR( a ); } writestr(stream, ")"); return 1; }
/* FIXME: Remove named let in this boot expander. */ static SCM expand_named_let (const SCM expr, SCM env) { SCM var_names, var_syms, inits; SCM inner_env; SCM name_sym; const SCM cdr_expr = CDR (expr); const SCM name = CAR (cdr_expr); const SCM cddr_expr = CDR (cdr_expr); const SCM bindings = CAR (cddr_expr); check_bindings (bindings, expr); transform_bindings (bindings, expr, &var_names, &var_syms, &inits); name_sym = scm_gensym (SCM_UNDEFINED); inner_env = scm_acons (name, name_sym, env); inner_env = expand_env_extend (inner_env, var_names, var_syms); return LETREC (scm_source_properties (expr), SCM_BOOL_F, scm_list_1 (name), scm_list_1 (name_sym), scm_list_1 (LAMBDA (SCM_BOOL_F, SCM_EOL, LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, var_syms, expand_sequence (CDDDR (expr), inner_env), SCM_BOOL_F))), CALL (SCM_BOOL_F, LEXICAL_REF (SCM_BOOL_F, name, name_sym), expand_exprs (inits, env))); }
Value *eval_if(Value *form, Value *env) { if (!LISP_NILP(eval(CADR(form), env))) { return eval(CADDR(form), env); } else { return eval(CAR(CDDDR(form)), env); } }
/* 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; }