static sexp sexp_qsort_less (sexp ctx, sexp *vec,
sexp_sint_t lo, sexp_sint_t hi,
sexp less, sexp key) {
sexp_sint_t mid, i, j;
sexp tmp, res, args1;
sexp_gc_var3(a, b, args2);
sexp_gc_preserve3(ctx, a, b, args2);
args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
args1 = sexp_cdr(args2);
loop:
if (lo >= hi) {
res = SEXP_VOID;
} else {
mid = lo + (hi-lo)/2;
swap(tmp, vec[mid], vec[hi]);
if (sexp_truep(key)) {
sexp_car(args1) = tmp;
b = sexp_apply(ctx, key, args1);
} else {
b = tmp;
}
for (i=j=lo; i < hi; i++) {
if (sexp_truep(key)) {
sexp_car(args1) = vec[i];
a = sexp_apply(ctx, key, args1);
} else {
a = vec[i];
}
sexp_car(args2) = a;
sexp_car(args1) = b;
res = sexp_apply(ctx, less, args2);
if (sexp_exceptionp(res))
goto done;
else if (sexp_truep(res))
swap(res, vec[i], vec[j]), j++;
}
swap(tmp, vec[j], vec[hi]);
res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
if (sexp_exceptionp(res))
goto done;
if (j < hi-1) {
lo = j;
goto loop; /* tail recurse on right side */
}
}
done:
sexp_gc_release3(ctx);
return res;
}
static int sexp_cookie_cleaner (void *cookie) {
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_close(vec))) return 0;
ctx = sexp_cookie_ctx(vec);
res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL);
return (sexp_exceptionp(res) ? -1 : sexp_truep(res));
}
static sexp check_exception (sexp ctx, sexp res) {
sexp_gc_var4(err, advise, sym, tmp);
if (res && sexp_exceptionp(res)) {
sexp_gc_preserve4(ctx, err, advise, sym, tmp);
tmp = res;
err = sexp_current_error_port(ctx);
if (! sexp_oportp(err))
err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_print_exception(ctx, res, err);
sexp_stack_trace(ctx, err);
#if SEXP_USE_MAIN_ERROR_ADVISE
if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV))) {
advise = sexp_eval_string(ctx, sexp_advice_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
if (sexp_vectorp(advise)) {
advise = sexp_vector_ref(advise, SEXP_ONE);
if (sexp_envp(advise)) {
sym = sexp_intern(ctx, "repl-advise-exception", -1);
advise = sexp_env_ref(ctx, advise, sym, SEXP_FALSE);
if (sexp_procedurep(advise))
sexp_apply(ctx, advise, tmp=sexp_list2(ctx, res, err));
}
}
}
#endif
sexp_gc_release4(ctx);
exit_failure();
}
return res;
}
void sexp_resume() {
sexp_gc_var1(tmp);
sexp_gc_preserve1(sexp_resume_ctx, tmp);
tmp = sexp_list1(sexp_resume_ctx, SEXP_VOID);
if (sexp_applicablep(sexp_resume_proc)) {
sexp_resume_proc = check_exception(sexp_resume_ctx, sexp_apply(sexp_resume_ctx, sexp_resume_proc, tmp));
}
sexp_gc_release1(sexp_resume_ctx);
}
void sexp_9p_destroyreq (Req *r) {
sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux;
sexp ctx = s->context;
sexp_gc_var(ptr, s_ptr);
sexp_gc_var(args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, s->destroyreq, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
void sexp_9p_end (Srv *srv) {
sexp_plan9_srv s = (sexp_plan9_srv)srv->aux;
sexp ctx = s->context;
sexp_gc_var(ptr, s_ptr);
sexp_gc_var(args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, s->end, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) {
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
args = sexp_make_integer(ctx, *position);
args = sexp_list2(ctx, args, sexp_make_fixnum(whence));
res = sexp_apply(ctx, sexp_cookie_seek(vec), args);
if (sexp_fixnump(res))
*position = sexp_unbox_fixnum(res);
sexp_gc_release2(ctx);
return sexp_fixnump(res);
}
char* sexp_9p_clone (Fid *oldfid, Fid *newfid) {
sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux;
sexp res, ctx = s->context;
sexp_gc_var(ptr, s_ptr);
sexp_gc_var(args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, args);
res = sexp_apply(ctx, s->clone, args);
sexp_gc_release(ctx, ptr, s_ptr);
return sexp_stringp(res) ? sexp_string_data(res) : nil;
}
static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size)
#endif
{
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_write(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
if (size > sexp_string_length(sexp_cookie_buffer(vec)))
sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size);
args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
res = sexp_apply(ctx, sexp_cookie_write(vec), args);
sexp_gc_release2(ctx);
return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1);
}
char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) {
sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux;
sexp res, ctx = s->context;
sexp_gc_var(ptr, s_ptr);
sexp_gc_var(args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
ptr = sexp_c_string(ctx, name, -1);
args = sexp_cons(ctx, ptr, args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, args);
res = sexp_apply(ctx, s->walk1, args);
sexp_gc_release(ctx, ptr, s_ptr);
return sexp_stringp(res) ? sexp_string_data(res) : nil;
}
static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size)
#endif
{
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_read(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
if (size > sexp_string_size(sexp_cookie_buffer(vec)))
sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID));
args = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(size));
args = sexp_cons(ctx, sexp_cookie_buffer(vec), args);
res = sexp_apply(ctx, sexp_cookie_read(vec), args);
sexp_gc_release2(ctx);
if (sexp_fixnump(res)) {
memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res));
return sexp_unbox_fixnum(res);
} else {
return -1;
}
}
static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) {
sexp ctx;
#if ! SEXP_USE_GREEN_THREADS
sexp sigctx, handler;
sexp_gc_var1(args);
#endif
ctx = sexp_signal_contexts[signum];
if (ctx) {
#if SEXP_USE_GREEN_THREADS
sexp_global(ctx, SEXP_G_THREADS_SIGNALS) =
sexp_make_fixnum((1UL<<signum) | sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)));
#else
handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS),
sexp_make_fixnum(signum));
if (sexp_applicablep(handler)) {
sigctx = sexp_make_child_context(ctx, NULL);
sexp_gc_preserve1(sigctx, args);
args = sexp_cons(sigctx, sexp_make_fixnum(signum), SEXP_NULL);
sexp_apply(sigctx, handler, args);
sexp_gc_release1(sigctx);
}
#endif
}
}
sexp run_main (int argc, char **argv) {
#if SEXP_USE_MODULES
char *impmod;
#endif
char *arg;
const char *prefix=NULL, *suffix=NULL, *main_symbol=NULL, *main_module=NULL;
sexp_sint_t i, j, c, quit=0, print=0, init_loaded=0, mods_loaded=0,
fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS, nonblocking=0;
sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE;
sexp out=SEXP_FALSE, ctx=NULL, ls;
sexp_gc_var4(tmp, sym, args, env);
args = SEXP_NULL;
env = NULL;
/* SRFI 22: invoke `main` procedure by default if the interpreter is */
/* invoked as `scheme-r7rs`. */
arg = strrchr(argv[0], '/');
if (strncmp((arg == NULL ? argv[0] : arg + 1), "scheme-r7rs", strlen("scheme-r7rs")) == 0) {
main_symbol = "main";
/* skip option parsing since we can't pass `--` before the name of script */
/* to avoid misinterpret the name as options when the interpreter is */
/* executed via `#!/usr/env/bin scheme-r7rs` shebang. */
i = 1;
goto done_options;
}
/* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) {
switch ((c=argv[i][1])) {
case 'D':
init_context();
arg = (argv[i][2] == '\0') ? argv[++i] : argv[i]+2;
sym = sexp_intern(ctx, arg, -1);
ls = sexp_global(ctx, SEXP_G_FEATURES);
if (sexp_pairp(ls)) {
for (; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
;
sexp_cdr(ls) = sexp_cons(ctx, sym, SEXP_NULL);
}
break;
case 'e':
case 'p':
mods_loaded = 1;
load_init(0);
print = (argv[i][1] == 'p');
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('e', arg);
tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env));
if (print) {
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write(ctx, tmp, out);
sexp_write_char(ctx, '\n', out);
}
quit = 1;
break;
case 'l':
mods_loaded = 1;
load_init(0);
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('l', arg);
check_exception(ctx, sexp_load_module_file(ctx, arg, env));
break;
case 'x':
prefix = sexp_environment_prefix;
suffix = sexp_environment_suffix;
case 'm':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
if (c == 'x') {
if (strcmp(arg, "chibi.primitive") == 0) {
goto load_primitive;
} else if (strcmp(arg, "scheme.small") == 0) {
load_init(0);
break;
}
} else {
prefix = sexp_import_prefix;
suffix = sexp_import_suffix;
}
mods_loaded = 1;
load_init(c == 'x');
#if SEXP_USE_MODULES
check_nonull_arg(c, arg);
impmod = make_import(prefix, arg, suffix);
tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, (c=='x' ? sexp_global(ctx, SEXP_G_META_ENV) : env)));
free(impmod);
if (c == 'x') {
sexp_set_parameter(ctx, sexp_global(ctx, SEXP_G_META_ENV), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), tmp);
sexp_context_env(ctx) = env = tmp;
sexp_add_import_binding(ctx, env);
tmp = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
if (tmp != NULL && !sexp_oportp(tmp)) {
sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
}
}
#endif
break;
load_primitive:
case 'Q':
init_context();
mods_loaded = 1;
if (! init_loaded++)
sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
handle_noarg();
break;
case 'q':
argv[i--] = (char*)"-xchibi";
break;
case 'A':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('A', arg);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE);
break;
case 'I':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('I', arg);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE);
break;
#if SEXP_USE_GREEN_THREADS
case 'b':
nonblocking = 1;
break;
#endif
case '-':
if (argv[i][2] == '\0') {
i++;
goto done_options;
}
sexp_usage(1);
case 'h':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('h', arg);
#if ! SEXP_USE_BOEHM
heap_size = strtoul(arg, &arg, 0);
if (sexp_isalpha((unsigned char)*arg)) heap_size *= multiplier(*arg++);
if (*arg == '/') {
heap_max_size = strtoul(arg+1, &arg, 0);
if (sexp_isalpha((unsigned char)*arg)) heap_max_size *= multiplier(*arg++);
}
#endif
break;
#if SEXP_USE_IMAGE_LOADING
case 'i':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
if (ctx) {
fprintf(stderr, "-:i <file>: image files must be loaded first\n");
exit_failure();
}
ctx = sexp_load_image(arg, 0, heap_size, heap_max_size);
if (!ctx || !sexp_contextp(ctx)) {
fprintf(stderr, "-:i <file>: couldn't open image file for reading: %s\n", arg);
fprintf(stderr, " %s\n", sexp_load_image_err());
ctx = NULL;
} else {
env = sexp_load_standard_params(ctx, sexp_context_env(ctx), nonblocking);
init_loaded++;
}
break;
case 'd':
if (! init_loaded++) {
init_context();
env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
}
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
if (sexp_save_image(ctx, arg) != SEXP_TRUE) {
fprintf(stderr, "-d <file>: couldn't save image to file: %s\n", arg);
fprintf(stderr, " %s\n", sexp_load_image_err());
exit_failure();
}
quit = 1;
break;
#endif
case 'V':
load_init(1);
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write_string(ctx, sexp_version_string, out);
tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL);
sexp_write(ctx, tmp, out);
sexp_newline(ctx, out);
return SEXP_TRUE;
#if SEXP_USE_FOLD_CASE_SYMS
case 'f':
fold_case = 1;
init_context();
sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE;
handle_noarg();
break;
#endif
case 'R':
main_module = argv[i][2] != '\0' ? argv[i]+2 :
(i+1 < argc && argv[i+1][0] != '-') ? argv[++i] : "chibi.repl";
if (main_symbol == NULL) main_symbol = "main";
break;
case 'r':
main_symbol = argv[i][2] == '\0' ? "main" : argv[i]+2;
break;
case 's':
init_context(); sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_TRUE;
handle_noarg();
break;
case 'T':
init_context(); sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P) = SEXP_TRUE;
handle_noarg();
break;
case 't':
mods_loaded = 1;
load_init(1);
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
#if SEXP_USE_MODULES
check_nonull_arg('t', arg);
suffix = strrchr(arg, '.');
sym = sexp_intern(ctx, suffix + 1, -1);
*(char*)suffix = '\0';
impmod = make_import(sexp_trace_prefix, arg, sexp_trace_suffix);
tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
if (!(tmp && sexp_envp(tmp))) {
fprintf(stderr, "couldn't find library to trace: %s\n", impmod);
} else if (!((sym = sexp_env_cell(ctx, tmp, sym, 0)))) {
fprintf(stderr, "couldn't find binding to trace: %s in %s\n", suffix + 1, impmod);
} else {
sym = sexp_list1(ctx, sym);
tmp = check_exception(ctx, sexp_eval_string(ctx, "(environment '(chibi trace))", -1, sexp_meta_env(ctx)));
tmp = sexp_env_ref(ctx, tmp, sexp_intern(ctx, "trace-cell", -1), 0);
if (tmp && sexp_procedurep(tmp))
check_exception(ctx, sexp_apply(ctx, tmp, sym));
}
free(impmod);
#endif
break;
default:
fprintf(stderr, "unknown option: %s\n", argv[i]);
/* ... FALLTHROUGH ... */
case '?':
sexp_usage(1);
}
}
done_options:
if (!quit || main_symbol != NULL) {
init_context();
/* build argument list */
if (i < argc)
for (j=argc-1; j>=i; j--)
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
if (i >= argc || main_symbol != NULL)
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
load_init(i < argc || main_symbol != NULL);
sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args);
if (i >= argc && main_symbol == NULL) {
/* no script or main, run interactively */
repl(ctx, env);
} else {
#if SEXP_USE_MODULES
/* load the module or script */
if (main_module != NULL) {
impmod = make_import("(load-module '(", main_module, "))");
env = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
if (sexp_vectorp(env)) env = sexp_vector_ref(env, SEXP_ONE);
free(impmod);
check_exception(ctx, env);
if (!sexp_envp(env)) {
fprintf(stderr, "couldn't find module: %s\n", main_module);
exit_failure();
}
} else
#endif
if (i < argc) { /* script usage */
#if SEXP_USE_MODULES
/* reset the environment to have only the `import' and */
/* `cond-expand' bindings */
if (!mods_loaded) {
env = sexp_make_env(ctx);
sexp_set_parameter(ctx, sexp_meta_env(ctx),
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_context_env(ctx) = env;
sym = sexp_intern(ctx, "repl-import", -1);
tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
sym = sexp_intern(ctx, "import", -1);
check_exception(ctx, sexp_env_define(ctx, env, sym, tmp));
sym = sexp_intern(ctx, "cond-expand", -1);
tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0);
#if SEXP_USE_RENAME_BINDINGS
sexp_env_rename(ctx, env, sym, tmp);
#endif
sexp_env_define(ctx, env, sym, sexp_cdr(tmp));
}
#endif
sexp_context_tracep(ctx) = 1;
tmp = sexp_env_bindings(env);
#if SEXP_USE_MODULES
/* use scheme load if possible for better stack traces */
sym = sexp_intern(ctx, "load", -1);
tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE);
if (sexp_procedurep(tmp)) {
sym = sexp_c_string(ctx, argv[i], -1);
sym = sexp_list2(ctx, sym, env);
tmp = check_exception(ctx, sexp_apply(ctx, tmp, sym));
} else
#endif
tmp = check_exception(ctx, sexp_load(ctx, sym=sexp_c_string(ctx, argv[i], -1), env));
#if SEXP_USE_WARN_UNDEFS
sexp_warn_undefs(ctx, env, tmp, SEXP_VOID);
#endif
#ifdef EMSCRIPTEN
if (sexp_applicablep(tmp)) {
sexp_resume_ctx = ctx;
sexp_resume_proc = tmp;
sexp_preserve_object(ctx, sexp_resume_proc);
emscripten_exit_with_live_runtime();
}
#endif
}
/* SRFI-22: run main if specified */
if (main_symbol) {
sym = sexp_intern(ctx, main_symbol, -1);
tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE);
if (sexp_procedurep(tmp)) {
args = sexp_list1(ctx, sexp_cdr(args));
check_exception(ctx, sexp_apply(ctx, tmp, args));
} else {
fprintf(stderr, "couldn't find main binding: %s in %s\n", main_symbol, main_module ? main_module : argv[i]);
}
}
}
}
sexp_gc_release4(ctx);
if (sexp_destroy_context(ctx) == SEXP_FALSE) {
fprintf(stderr, "destroy_context error\n");
return SEXP_FALSE;
}
return SEXP_TRUE;
}
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;
}
void run_main (int argc, char **argv) {
char *arg, *impmod, *p;
sexp out=SEXP_FALSE, env=NULL, ctx=NULL;
sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0, fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS;
sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE;
sexp_gc_var2(tmp, args);
args = SEXP_NULL;
/* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) {
switch (argv[i][1]) {
case 'e':
case 'p':
load_init();
print = (argv[i][1] == 'p');
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('e', arg);
tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env));
if (print) {
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write(ctx, tmp, out);
sexp_write_char(ctx, '\n', out);
}
quit = 1;
break;
case 'l':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('l', arg);
check_exception(ctx, sexp_load_module_file(ctx, arg, env));
break;
case 'm':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('m', arg);
len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix);
impmod = (char*) malloc(len+1);
strcpy(impmod, sexp_import_prefix);
strcpy(impmod+strlen(sexp_import_prefix), arg);
strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix);
impmod[len] = '\0';
for (p=impmod; *p; p++)
if (*p == '.') *p=' ';
check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env));
free(impmod);
break;
case 'q':
init_context();
if (! init_loaded++)
sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
break;
case 'A':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('A', arg);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE);
break;
case 'I':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('I', arg);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE);
break;
case '-':
i++;
goto done_options;
case 'h':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('h', arg);
heap_size = strtoul(arg, &arg, 0);
if (sexp_isalpha(*arg)) heap_size *= multiplier(*arg++);
if (*arg == '/') {
heap_max_size = strtoul(arg+1, &arg, 0);
if (sexp_isalpha(*arg)) heap_max_size *= multiplier(*arg++);
}
break;
case 'V':
load_init();
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write_string(ctx, sexp_version_string, out);
tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL);
sexp_write(ctx, tmp, out);
sexp_newline(ctx, out);
return;
#if SEXP_USE_FOLD_CASE_SYMS
case 'f':
fold_case = 1;
if (ctx) sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE;
break;
#endif
default:
fprintf(stderr, "unknown option: %s\n", argv[i]);
exit_failure();
}
}
done_options:
if (! quit) {
load_init();
if (i < argc)
for (j=argc-1; j>i; j--)
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
else
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args);
sexp_eval_string(ctx, sexp_argv_proc, -1, env);
if (i < argc) { /* script usage */
sexp_context_tracep(ctx) = 1;
check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env));
tmp = sexp_intern(ctx, "main", -1);
tmp = sexp_env_ref(env, tmp, SEXP_FALSE);
if (sexp_procedurep(tmp)) {
args = sexp_list1(ctx, args);
check_exception(ctx, sexp_apply(ctx, tmp, args));
}
} else {
repl(ctx, env);
}
}
sexp_gc_release2(ctx);
sexp_destroy_context(ctx);
}