static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, sexp read, sexp write, sexp seek, sexp close) { sexp vec; sexp_gc_var2(res, str); sexp_gc_preserve2(ctx, res, str); str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); if (sexp_exceptionp(str)) return str; res = sexp_open_input_string(ctx, str); if (sexp_exceptionp(res)) return res; if (mode && mode[0] == 'w') { sexp_pointer_tag(res) = SEXP_OPORT; sexp_port_cookie(res) = str; } else { sexp_port_offset(res) = 0; sexp_port_size(res) = 0; } vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); if (sexp_exceptionp(vec)) return vec; sexp_vector_set(vec, SEXP_ZERO, SEXP_FALSE); sexp_vector_set(vec, SEXP_ONE, sexp_port_cookie(res)); sexp_vector_set(vec, SEXP_TWO, read); sexp_vector_set(vec, SEXP_THREE, write); sexp_vector_set(vec, SEXP_FOUR, seek); sexp_vector_set(vec, SEXP_FIVE, close); sexp_port_cookie(res) = vec; sexp_gc_release2(ctx); return res; }
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; }
static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k, int bootp, int nonblocking) { sexp_gc_var1(e); sexp_gc_preserve1(ctx, e); e = sexp_load_standard_env(ctx, env, k); if (!sexp_exceptionp(e)) { #if SEXP_USE_MODULES if (!bootp) e = sexp_eval_string(ctx, sexp_default_environment, -1, sexp_global(ctx, SEXP_G_META_ENV)); if (!sexp_exceptionp(e)) sexp_add_import_binding(ctx, e); #endif if (!sexp_exceptionp(e)) e = sexp_load_standard_params(ctx, e, nonblocking); } sexp_gc_release1(ctx); return e; }
sexp sexp_make_custom_output_port (sexp ctx, sexp self, sexp write, sexp seek, sexp close) { sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); #if SEXP_USE_STRING_STREAMS if (!sexp_exceptionp(res)) sexp_pointer_tag(res) = SEXP_OPORT; #endif return res; }
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 sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { sexp res; sexp_gc_var1(state); sexp_gc_preserve1(ctx, state); state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF); res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id); if (sexp_exceptionp(res)) return res; sexp_random_state(res) = state; sexp_random_init(res, 1); sexp_gc_release1(ctx); return res; }
static sexp check_exception (sexp ctx, sexp res) { sexp err; if (res && sexp_exceptionp(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); exit_failure(); } return res; }
static void repl (sexp ctx, sexp env) { sexp in, out, err; sexp_gc_var3(obj, tmp, res); sexp_gc_preserve3(ctx, obj, tmp, res); 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)); 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 { tmp = sexp_env_bindings(env); sexp_context_top(ctx) = 0; res = sexp_eval(ctx, obj, env); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); sexp_stack_trace(ctx, err); } else { #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); #endif if (res != SEXP_VOID) { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } } } } sexp_gc_release3(ctx); }
static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) { sexp_gc_var3(e, p, res); sexp_gc_preserve3(ctx, e, p, res); e = sexp_load_standard_env(ctx, env, k); if (sexp_exceptionp(e)) return e; sexp_load_standard_ports(ctx, e, stdin, stdout, stderr, 0); #if SEXP_USE_GREEN_THREADS p = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)); if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1); #endif res = sexp_make_env(ctx); sexp_env_parent(res) = e; sexp_set_parameter(ctx, res, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), res); sexp_gc_release3(ctx); return res; }
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { sexp_gc_var2(name, op); if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) return SEXP_ABI_ERROR; sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx, NULL, 0); name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx, NULL, 0, default_random_source); sexp_gc_release2(ctx); return SEXP_VOID; }
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, sexp less, sexp key) { sexp_sint_t len; sexp res, *data; sexp_gc_var1(vec); if (sexp_nullp(seq)) return seq; sexp_gc_preserve1(ctx, vec); vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); if (! sexp_vectorp(vec)) { res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); } else { data = sexp_vector_data(vec); len = sexp_vector_length(vec); if (sexp_not(key) && sexp_basic_comparator(less)) { sexp_qsort(ctx, data, 0, len-1); if (sexp_opcodep(less) && sexp_opcode_inverse(less)) sexp_vector_nreverse(ctx, vec); res = vec; } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); } else { res = sexp_qsort_less(ctx, data, 0, len-1, less, key); } } if (sexp_pairp(seq) && ! sexp_exceptionp(res)) res = sexp_vector_copy_to_list(ctx, vec, seq); sexp_gc_release1(ctx); return res; }
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx sexp_api_pass(NULL, 0)); name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx sexp_api_pass(NULL, 0), default_random_source); sexp_gc_release2(ctx); return SEXP_VOID; }
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; }