Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

cleaning up initialization interface, adding sexp_load_standard_ports

Browse source
This commit is contained in:
Alex Shinn 2011-04-07 22:48:10 +09:00
parent fb5d82e7ba
commit 9b0c057343
5 changed files with 66 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
doc/chibi.scrbl
View file

@ -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 = ...

34
eval.c
View file

@ -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)) {

3
include/chibi/eval.h
View file

@ -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);

43
main.c
View file

@ -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);
}
}

4
tests/thread-tests.scm
View file

@ -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)