From 9b0c057343a75c3db5fd3441756cb07a23797e14 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 7 Apr 2011 22:48:10 +0900 Subject: [PATCH] cleaning up initialization interface, adding sexp_load_standard_ports --- doc/chibi.scrbl | 25 +++++++++++++++--------- eval.c | 34 +++++++++++++++++++-------------- include/chibi/eval.h | 3 ++- main.c | 43 +++++++++++++++++++++++++----------------- tests/thread-tests.scm | 4 ++-- 5 files changed, 66 insertions(+), 43 deletions(-) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index f6be143b..8a623030 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -295,6 +295,7 @@ int main(int argc, char** argv) { sexp ctx; ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0); sexp_load_standard_env(ctx, NULL, SEXP_SEVEN); + sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0); dostuff(ctx); sexp_destroy_context(ctx); } @@ -373,19 +374,25 @@ core forms: @scheme{define}, @scheme{set!}, @scheme{lambda}, @scheme{if}, @scheme{let-syntax}, and @scheme{letrec-syntax}. }} -@item{@ccode{sexp_load_standard_parameters(sexp ctx, sexp env)} -@p{ -Creates @scheme{current-input-port}, @scheme{current-output-port}, and -@scheme{current-error-port} parameters from stdin, stdout and stderr, and binds -them in @var{env}. Also creates an @scheme{interaction-environment} parameter -and sets @var{env} itself to that. -}} - @item{@ccode{sexp_load_standard_env(sexp ctx, sexp env, sexp version)} @p{ Loads the standard parameters for @var{env}, constructs the feature list from pre-compiled defaults, and loads the installed initialization file for @var{version}, which currently should be the value @var{SEXP_SEVEN}. +Also creates an @scheme{interaction-environment} parameter +and sets @var{env} itself to that. +}} + +@item{@ccode{sexp_load_standard_ports(sexp ctx, sexp env, FILE* in, FILE* out, FILE* err, int leave_open)} +@p{ +Creates @scheme{current-input-port}, @scheme{current-output-port}, and +@scheme{current-error-port} parameters from @var{in}, @var{out} and +@var{err}, and binds them in @var{env}. If @var{env} is @cvar{NULL} +the default context environment is used. Any of the @ctype{FILE*} may +be @cvar{NULL}, in which case the corresponding port is not set. If +@var{leave_open} is true, then the underlying @ctype{FILE*} is left +open after the Scheme port is closed, otherwise they are both closed +together. }} @item{@ccode{sexp_load(sexp ctx, sexp file, sexp env)} @@ -493,7 +500,7 @@ sexp foo(sexp ctx, sexp bar, sexp baz) { sexp_assert_type(ctx, sexp_bazp, SEXP_BAZ, baz); /* preserve the variables in ctx */ - sexp_gc_var3(ctx, tmp1, tmp2, res); + sexp_gc_preserve3(ctx, tmp1, tmp2, res); /* perform your computations */ tmp1 = ... diff --git a/eval.c b/eval.c index 0d642aeb..1414340a 100644 --- a/eval.c +++ b/eval.c @@ -1625,7 +1625,7 @@ sexp sexp_parameter_ref (sexp ctx, sexp param) { ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE; } -static void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { +void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { sexp param = sexp_env_ref(env, name, SEXP_FALSE); if (sexp_opcodep(param)) { if (! sexp_pairp(sexp_opcode_data(param))) @@ -1635,20 +1635,26 @@ static void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { } } -sexp sexp_load_standard_parameters (sexp ctx, sexp env) { - /* add io port and interaction env parameters */ +sexp sexp_load_standard_ports (sexp ctx, sexp env, FILE* in, FILE* out, + FILE* err, int no_close) { sexp_gc_var1(p); sexp_gc_preserve1(ctx, p); - p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); - sexp_port_no_closep(p) = 1; - sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); - p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); - sexp_port_no_closep(p) = 1; - sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); - p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); - sexp_port_no_closep(p) = 1; - sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); - sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + if (!env) env = sexp_context_env(ctx); + if (in) { + p = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + } + if (out) { + p = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + } + if (err) { + p = sexp_make_output_port(ctx, err, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + } sexp_gc_release1(ctx); return SEXP_VOID; } @@ -1657,7 +1663,6 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_gc_var3(op, tmp, sym); sexp_gc_preserve3(ctx, op, tmp, sym); if (!e) e = sexp_context_env(ctx); - sexp_load_standard_parameters(ctx, e); #if SEXP_USE_DL sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), tmp=sexp_c_string(ctx, sexp_so_extension, -1)); @@ -1697,6 +1702,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { = sexp_env_ref(e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE); /* load init.scm */ tmp = sexp_load_module_file(ctx, sexp_init_file, e); + sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); /* load and bind config env */ #if SEXP_USE_MODULES if (! sexp_exceptionp(tmp)) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5c5f01d6..f8737345 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -149,7 +149,8 @@ SEXP_API sexp sexp_make_env_op (sexp context sexp_api_params(self, n)); SEXP_API sexp sexp_make_null_env_op (sexp context sexp_api_params(self, n), sexp version); SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); SEXP_API sexp sexp_make_standard_env_op (sexp context sexp_api_params(self, n), sexp version); -SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); +SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value); +SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close); SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env); diff --git a/main.c b/main.c index 4cdb8769..e928a4e2 100644 --- a/main.c +++ b/main.c @@ -23,12 +23,10 @@ static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) { return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : SEXP_VOID; } -static void repl (sexp ctx) { +static void repl (sexp ctx, sexp env) { sexp in, out, err; - sexp_gc_var4(obj, tmp, res, env); - sexp_gc_preserve4(ctx, obj, tmp, res, env); - env = sexp_make_env(ctx); - sexp_env_parent(env) = sexp_context_env(ctx); + 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)); @@ -62,7 +60,7 @@ static void repl (sexp ctx) { } } } - sexp_gc_release4(ctx); + sexp_gc_release3(ctx); } static sexp_uint_t multiplier (char c) { @@ -95,31 +93,41 @@ static sexp check_exception (sexp ctx, sexp res) { } static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) { - sexp e = sexp_load_standard_env(ctx, env, k), p, res; + 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; } +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(); + } + sexp_global(*ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(fold_case); + *env = sexp_context_env(*ctx); +} + #define init_context() if (! ctx) do { \ - 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(); \ - } \ - sexp_global(ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(fold_case); \ - env = sexp_context_env(ctx); \ + do_init_context(&ctx, &env, heap_size, heap_max_size, fold_case); \ sexp_gc_preserve2(ctx, tmp, args); \ } while (0) #define load_init() if (! init_loaded++) do { \ init_context(); \ - check_exception(ctx, sexp_load_standard_repl_env(ctx, env, SEXP_SEVEN)); \ + check_exception(ctx, env=sexp_load_standard_repl_env(ctx, env, SEXP_SEVEN)); \ } while (0) void run_main (int argc, char **argv) { @@ -171,7 +179,8 @@ void run_main (int argc, char **argv) { break; case 'q': init_context(); - if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + if (! init_loaded++) + sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); break; case 'A': init_context(); @@ -237,7 +246,7 @@ void run_main (int argc, char **argv) { check_exception(ctx, sexp_apply(ctx, tmp, args)); } } else { - repl(ctx); + repl(ctx, env); } } diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm index 53221613..32ef8a74 100644 --- a/tests/thread-tests.scm +++ b/tests/thread-tests.scm @@ -8,12 +8,12 @@ (test "ignored thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok) 'ok) (test "ignored thread hangs" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) 'ok) 'ok) (test "joined thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) (thread-join! t) 'ok) 'ok) -(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 1 'timeout)) 'timeout) +(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 0.1 'timeout)) 'timeout) (test "basic mutex" (let ((m (make-mutex))) (and (mutex? m) 'ok)) 'ok) (test "mutex unlock" (let ((m (make-mutex))) (and (mutex-unlock! m) 'ok)) 'ok) (test "mutex lock/unlock" (let ((m (make-mutex))) (and (mutex-lock! m) (mutex-unlock! m) 'ok)) 'ok) -(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 1) 'fail 'timeout)) 'timeout) +(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 0.1) 'fail 'timeout)) 'timeout) ;(test "basic condition-variable" () 'ok) ;(test "condition-variable signal" () 'ok)