int main()
{
sexp ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0);
sexp_load_standard_env(ctx, NULL, SEXP_SEVEN);
sexp_gc_var1(score);
sexp_gc_preserve1(ctx, score);
bool ret = ext::load_file(ctx, "mammon.ss");
if (!ret) {
std::cout << "Could not find configuration file `mammon.ss`."
<< std::endl;
return 1;
}
score = sexp_eval_string(ctx, "score", -1, NULL);
if (sexp_procedurep(score)) {
score::ext_score = [&ctx](const char *b, const char *t) {
return ext::call_fun_str2(ctx, "score", b, t);
};
}
const auto boards = ext::config_get_list(ctx, "boards");
if (boards.empty()) {
std::cout << "Please add a value for `boards` in your configuration "
"file.\ne.g. (define boards '(\"g\" \"a\" \"k\"))" << std::endl;
return 1;
}
const std::string dom = ext::config_get_str(ctx, "dom", "");
std::unique_ptr<chan_proc> pc;
if (dom == "4chan") {
pc = std::unique_ptr<chan_proc>(new fourchan_proc());
} else if (dom == "8chan") {
std::string url = ext::config_get_str(ctx, "url-8chan", "");
pc = std::unique_ptr<chan_proc>(new eightchan_proc(std::move(url)));
} else {
std::cout << "Please specify a value for `dom` in your configuration "
"file.\nPossible values are:" << std::endl;
std::cout
<< "\t4chan\n"
<< "\t8chan\n"
<< std::endl;
return 1;
}
for (const auto &b: boards)
pc->proc_board(b);
sexp_gc_release1(ctx);
sexp_destroy_context(ctx);
return 0;
}
static void do_init_context (sexp* ctx, sexp* env, sexp_uint_t heap_size,
sexp_uint_t heap_max_size, sexp_sint_t fold_case) {
*ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size, heap_max_size);
if (! *ctx) {
fprintf(stderr, "chibi-scheme: out of memory\n");
exit_failure();
}
#if SEXP_USE_FOLD_CASE_SYMS
sexp_global(*ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(fold_case);
#endif
*env = sexp_context_env(*ctx);
}
sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) {
sexp res, *stack;
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
sexp_context_proc(res) = thunk;
sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
stack = sexp_stack_data(sexp_context_stack(res));
stack[0] = stack[1] = stack[3] = SEXP_ZERO;
stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
sexp_context_top(res) = 4;
sexp_context_last_fp(res) = 0;
return res;
}
sexp sexp_make_thread (sexp ctx, sexp self, sexp_sint_t n, sexp thunk, sexp name) {
sexp *stack;
sexp_gc_var1(res);
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
sexp_gc_preserve1(ctx, res);
res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0, 0);
sexp_context_name(res) = name;
sexp_context_proc(res) = thunk;
sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
stack = sexp_stack_data(sexp_context_stack(res));
stack[0] = stack[1] = stack[3] = SEXP_ZERO;
stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
sexp_context_top(res) = 4;
sexp_context_last_fp(res) = 0;
sexp_context_dk(res) = sexp_list1(ctx, SEXP_FALSE);
sexp_gc_release1(ctx);
return res;
}
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;
}
