static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) { size_t freed; sexp_uint_t sizes[512]; sexp_sint_t i; sexp_heap h = sexp_context_heap(ctx); sexp_free_list q; sexp_gc_var2(res, tmp); /* run gc once to remove unused variables */ sexp_gc(ctx, &freed); /* initialize stats */ for (i=0; i<512; i++) sizes[i]=0; /* loop over each free block */ for ( ; h; h=h->next) for (q=h->free_list; q; q=q->next) sizes[sexp_heap_chunks(q->size) > 511 ? 511 : sexp_heap_chunks(q->size)]++; /* build and return results */ sexp_gc_preserve2(ctx, res, tmp); res = SEXP_NULL; for (i=511; 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); } sexp_gc_release2(ctx); return res; }
static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { size_t freed; sexp_uint_t stats[256], hi_type=0, i; sexp_heap h = sexp_context_heap(ctx); sexp p, out=SEXP_FALSE; sexp_free_list q, r; char *end; sexp_gc_var3(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; /* 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)]++; if (sexp_pointer_tag(p) > hi_type) hi_type = sexp_pointer_tag(p); p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); } } /* build and return results */ sexp_gc_preserve3(ctx, res, tmp, name); 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])); res = sexp_cons(ctx, tmp, res); } sexp_gc_release3(ctx); return res; }
static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #if SEXP_USE_FLONUMS double d; #endif sexp ls1=SEXP_NULL, ls2; sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread); ls2 = sexp_global(ctx, SEXP_G_THREADS_PAUSED); if (sexp_realp(timeout)) gettimeofday(&sexp_context_timeval(thread), NULL); if (sexp_fixnump(timeout)) { sexp_context_timeval(thread).tv_sec += sexp_unbox_fixnum(timeout); #if SEXP_USE_FLONUMS } else if (sexp_flonump(timeout)) { d = sexp_flonum_value(timeout); sexp_context_timeval(thread).tv_sec += trunc(d); sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; if (sexp_context_timeval(thread).tv_usec > 1000000) { sexp_context_timeval(thread).tv_sec += 1; sexp_context_timeval(thread).tv_usec -= 1000000; } #endif #if SEXP_USE_RATIOS } else if (sexp_ratiop(timeout)) { d = sexp_ratio_to_double(timeout); sexp_context_timeval(thread).tv_sec += trunc(d); sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; if (sexp_context_timeval(thread).tv_usec > 1000000) { sexp_context_timeval(thread).tv_sec += 1; sexp_context_timeval(thread).tv_usec -= 1000000; } #endif } else if (sexp_contextp(timeout)) { sexp_context_timeval(thread).tv_sec = sexp_context_timeval(timeout).tv_sec; sexp_context_timeval(thread).tv_usec = sexp_context_timeval(timeout).tv_usec; } else { sexp_context_timeval(thread).tv_sec = 0; sexp_context_timeval(thread).tv_usec = 0; } if (sexp_realp(timeout) || sexp_contextp(timeout)) while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread))) ls1=ls2, ls2=sexp_cdr(ls2); else while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) ls1=ls2, ls2=sexp_cdr(ls2); if (ls1 == SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); else sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); }
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 sexp sexp_translate_opcode_type (sexp ctx, sexp type) { sexp_gc_var2(res, tmp); res = type; if (! res) { res = sexp_type_by_index(ctx, SEXP_OBJECT); } if (sexp_fixnump(res)) { res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); } else if (sexp_nullp(res)) { /* opcode list types */ sexp_gc_preserve2(ctx, res, tmp); tmp = sexp_intern(ctx, "or", -1); res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); res = sexp_cons(ctx, tmp, res); sexp_gc_release2(ctx); } return res; }
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; }
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); }
sexp sexp_thread_start (sexp ctx, sexp self, sexp_sint_t n, sexp thread) { sexp cell; sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); cell = sexp_cons(ctx, thread, SEXP_NULL); if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; } else { /* init queue */ sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; } return thread; }
sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) { double second; int leap_second_indicator; sexp_gc_var3(res, car, cdr); current_ntp_clock_values (&second, &leap_second_indicator); sexp_gc_preserve3(ctx, res, car, cdr); cdr = sexp_make_boolean(leap_second_indicator); car = sexp_make_flonum(ctx, second); res = sexp_cons(ctx, car, cdr); sexp_gc_release3(ctx); return res; }
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); }
static sexp sexp_yuniffi_nccc_proc_register(sexp ctx, sexp self, sexp_sint_t n, sexp proc){ sexp_gc_var2(res, resptr); REQUIRE(ctx, self, proc, sexp_procedurep, SEXP_PROCEDURE); sexp_gc_preserve2(ctx, res, resptr); res = sexp_cons(ctx, ctx, proc); resptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, (void*)(uintptr_t)res, SEXP_FALSE, 0); sexp_preserve_object(ctx, res); sexp_gc_release2(ctx); return resptr; }
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_size(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_ZERO, sexp_make_fixnum(size)); args = sexp_cons(ctx, sexp_cookie_buffer(vec), args); res = sexp_apply(ctx, sexp_cookie_write(vec), args); sexp_gc_release2(ctx); return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -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; }
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); }
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; }
int sexp_read(IOHandle *h, sexp_t **result_ptr) { cmsg_bytes_t buf; sexp_t *stack = NULL; /* held */ sexp_t *hint = NULL; /* held */ sexp_t *body = NULL; /* held */ sexp_t *accumulator = NULL; /* not held */ while (1) { READ1; switch (buf.bytes[0]) { case '[': { iohandle_drain(h, 1); hint = INCREF(read_simple_string(h, EMPTY_BYTES)); if (hint == NULL) goto error; READ1; if (buf.bytes[0] != ']') { h->error_kind = SEXP_ERROR_SYNTAX; goto error; } iohandle_drain(h, 1); skip_whitespace_in_display_hint: READ1; if (isspace(buf.bytes[0])) { iohandle_drain(h, 1); goto skip_whitespace_in_display_hint; } body = INCREF(read_simple_string(h, EMPTY_BYTES)); if (body == NULL) goto error; accumulator = sexp_display_hint(hint, body); DECREF(hint, sexp_destructor); /* these could be UNGRABs */ DECREF(body, sexp_destructor); break; } case '(': iohandle_drain(h, 1); stack = sexp_push(stack, sexp_cons(NULL, NULL)); continue; case ')': { sexp_t *current; if (stack == NULL) { h->error_kind = SEXP_ERROR_SYNTAX; goto error; } stack = sexp_pop(stack, ¤t); INCREF(current); iohandle_drain(h, 1); accumulator = INCREF(sexp_head(current)); DECREF(current, sexp_destructor); UNGRAB(accumulator); break; } default: if (isspace(buf.bytes[0])) { iohandle_drain(h, 1); continue; } buf.len = 1; /* needed to avoid reading too much in read_simple_string */ accumulator = read_simple_string(h, buf); if (accumulator == NULL) goto error; break; } if (stack == NULL) { *result_ptr = accumulator; return 1; } else { sexp_t *current = sexp_head(stack); /* not held */ sexp_t *cell = sexp_cons(accumulator, NULL); if (sexp_tail(current) == NULL) { sexp_sethead(current, cell); } else { sexp_settail(sexp_tail(current), cell); } sexp_settail(current, cell); } } error: DECREF(stack, sexp_destructor); DECREF(hint, sexp_destructor); DECREF(body, sexp_destructor); return 0; }