static void repl (sexp ctx, sexp env) { sexp_gc_var6(obj, tmp, res, in, out, err); sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err); sexp_context_tracep(ctx) = 1; in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)); out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); if (in == NULL || out == NULL) { fprintf(stderr, "Standard I/O ports not found, aborting. Maybe a bad -x language?\n"); exit_failure(); } if (err == NULL) err = out; sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); sexp_flush(ctx, out); sexp_maybe_block_port(ctx, in, 1); obj = sexp_read(ctx, in); sexp_maybe_unblock_port(ctx, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { sexp_print_exception(ctx, obj, err); } else { sexp_context_top(ctx) = 0; if (!(sexp_idp(obj)||sexp_pairp(obj)||sexp_nullp(obj))) obj = sexp_make_lit(ctx, obj); tmp = sexp_env_bindings(env); res = sexp_eval(ctx, obj, env); #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, res); #endif if (res && sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); if (res != sexp_global(ctx, SEXP_G_OOS_ERROR)) sexp_stack_trace(ctx, err); } else if (res != SEXP_VOID) { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } } } sexp_gc_release6(ctx); }
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { int check; sexp ls1, ls2, p1, p2, sv; sexp_gc_var5(res, substs, tmp, app, ctx2); sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2); res = ast; /* return the ast as-is by default */ substs = init_substs; loop: switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { case SEXP_PAIR: /* don't simplify the operator if it's a lambda because we simplify that as a special case below, with the appropriate substs list */ app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); sexp_pair_source(app) = sexp_pair_source(res); for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1); } app = sexp_nreverse(ctx, app); /* app now holds a copy of the list, and is the default result (res = app below) if we don't replace it with a simplification */ if (sexp_opcodep(sexp_car(app))) { /* opcode app - right now we just constant fold arithmetic */ if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { check = 0; break; } } if (check) { ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0); sexp_generate(ctx2, 0, 0, 0, app); res = sexp_complete_bytecode(ctx2); if (! sexp_exceptionp(res)) { tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); if (! sexp_exceptionp(tmp)) { tmp = sexp_apply(ctx2, tmp, SEXP_NULL); if (! sexp_exceptionp(tmp)) app = sexp_make_lit(ctx2, tmp); } } } } } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ p1 = NULL; p2 = sexp_lambda_params(sexp_car(app)); ls1 = app; ls2 = sexp_cdr(app); sv = sexp_lambda_sv(sexp_car(app)); if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) { for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) || (sexp_refp(sexp_car(ls2)) && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); tmp = sexp_cons(ctx, sexp_car(p2), tmp); sexp_push(ctx, substs, tmp); sexp_cdr(ls1) = sexp_cdr(ls2); if (p1) sexp_cdr(p1) = sexp_cdr(p2); else sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); } else { p1 = p2; ls1 = ls2; } } sexp_lambda_body(sexp_car(app)) = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); if (sexp_nullp(sexp_cdr(app)) && sexp_nullp(sexp_lambda_params(sexp_car(app))) && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) app = sexp_lambda_body(sexp_car(app)); } } res = app; break; case SEXP_LAMBDA: sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); break; case SEXP_CND: tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) ? sexp_cnd_fail(res) : sexp_cnd_pass(res); goto loop; } else { sexp_cnd_test(res) = tmp; simplify_it(sexp_cnd_pass(res)); simplify_it(sexp_cnd_fail(res)); } break; case SEXP_REF: tmp = sexp_ref_name(res); for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { res = sexp_cddar(ls1); break; } break; case SEXP_SET: simplify_it(sexp_set_value(res)); break; case SEXP_SEQ: app = SEXP_NULL; for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { tmp = simplify(ctx, sexp_car(ls2), substs, lambda); if (! (sexp_pairp(sexp_cdr(ls2)) && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) || sexp_lambdap(tmp)))) sexp_push(ctx, app, tmp); } if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) res = sexp_car(app); else sexp_seq_ls(res) = sexp_nreverse(ctx, app); break; } sexp_gc_release5(ctx); return res; }