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;
}
sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
sexp res;
sexp_gc_var4(k, i, a1, b1);
sexp_gc_preserve4(ctx, k, i, a1, b1);
a1 = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(a1) = 1;
b1 = sexp_copy_bignum(ctx, NULL, b, 0);
sexp_bignum_sign(b1) = 1;
k = sexp_copy_bignum(ctx, NULL, b1, 0);
i = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
res = quot_step(ctx, rem, a1, b1, k, i);
sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b);
if (sexp_bignum_sign(a) < 0) {
sexp_negate_exact(*rem);
}
sexp_gc_release4(ctx);
return res;
}
sexp sexp_complex_div (sexp ctx, sexp a, sexp b) {
sexp_gc_var4(res, real, imag, denom);
sexp_gc_preserve4(ctx, res, real, imag, denom);
/* c^2 + d^2 */
denom = sexp_mul(ctx, sexp_complex_real(b), sexp_complex_real(b));
res = sexp_mul(ctx, sexp_complex_imag(b), sexp_complex_imag(b));
denom = sexp_add(ctx, denom, res);
/* ac + bd */
real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b));
res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b));
real = sexp_add(ctx, real, res);
real = sexp_div(ctx, real, denom);
/* bc - ad */
imag = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b));
res = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b));
imag = sexp_sub(ctx, imag, res);
imag = sexp_div(ctx, imag, denom);
res = sexp_make_complex(ctx, real, imag);
sexp_gc_release4(ctx);
return sexp_complex_normalize(res);
}
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 sexp_heap_walk (sexp ctx, int depth, int printp) {
size_t freed;
sexp_uint_t stats[256], sizes[256], hi_type=0, size;
sexp_sint_t i;
sexp_heap h = sexp_context_heap(ctx);
sexp p, out=SEXP_FALSE;
sexp_free_list q, r;
char *end;
sexp_gc_var4(stats_res, res, tmp, name);
if (printp)
out = sexp_parameter_ref(ctx,
sexp_env_ref(ctx,
sexp_context_env(ctx),
sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
SEXP_FALSE));
/* run gc once to remove unused variables */
sexp_gc(ctx, &freed);
/* initialize stats */
for (i=0; i<256; i++) { stats[i]=0; sizes[i]=0; }
/* loop over each heap chunk */
for ( ; h; h=h->next) {
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
q = h->free_list;
end = (char*)h->data + h->size;
while (((char*)p) < end) {
/* find the preceding and succeeding free list pointers */
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
;
if ((char*)r == (char*)p) { /* this is a free block, skip */
p = (sexp) (((char*)p) + r->size);
continue;
}
/* otherwise maybe print, then increment the stat and continue */
if (sexp_oportp(out)) {
sexp_print_simple(ctx, p, out, depth);
sexp_write_char(ctx, '\n', out);
}
stats[sexp_pointer_tag(p) > 255 ? 255 : sexp_pointer_tag(p)]++;
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
sizes[sexp_heap_chunks(size) > 255 ? 255 : sexp_heap_chunks(size)]++;
if (sexp_pointer_tag(p) > hi_type)
hi_type = sexp_pointer_tag(p);
p = (sexp) (((char*)p) + size);
}
}
/* build and return results */
sexp_gc_preserve4(ctx, stats_res, res, tmp, name);
stats_res = SEXP_NULL;
for (i=hi_type; i>0; i--)
if (stats[i]) {
name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
stats_res = sexp_cons(ctx, tmp, stats_res);
}
res = SEXP_NULL;
for (i=255; i>=0; i--)
if (sizes[i]) {
tmp = sexp_cons(ctx, sexp_make_fixnum(i), sexp_make_fixnum(sizes[i]));
res = sexp_cons(ctx, tmp, res);
}
res = sexp_cons(ctx, stats_res, res);
sexp_gc_release4(ctx);
return res;
}
