Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

simplifying gc variable preservation

Browse source 
Adding sexp_gc_var1..6 and corresponding _preserve/release1..6
referring to fixed preservation variable names, to substantially
reduce the boilerplate on C functions which produce temporary sexp
values.  The fixed variable names are safe because we never nest
them within the same C function.  The original macros are still
available for manual naming, block local variables and cases of
more than 6 gc vars.

Consider combining var+preserve into a single macro, since splitting
them is rare.
This commit is contained in:
Alex Shinn 2009-11-01 19:48:30 +09:00
parent 445f8e9fa4
commit 576a20b3bc
4 changed files with 201 additions and 306 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

284
eval.c
View file

@ -31,16 +31,14 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version);
static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
sexp exn; sexp exn;
sexp_gc_var(ctx, irritants, s_irr); sexp_gc_var2(irritants, msg);
sexp_gc_var(ctx, msg, s_msg); sexp_gc_preserve2(ctx, irritants, msg);
sexp_gc_preserve(ctx, irritants, s_irr);
sexp_gc_preserve(ctx, msg, s_msg);
irritants = sexp_list1(ctx, obj); irritants = sexp_list1(ctx, obj);
msg = sexp_c_string(ctx, message, -1); msg = sexp_c_string(ctx, message, -1);
exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants,
SEXP_FALSE, (sexp_pairp(obj) ? SEXP_FALSE, (sexp_pairp(obj) ?
sexp_pair_source(obj) : SEXP_FALSE)); sexp_pair_source(obj) : SEXP_FALSE));
sexp_gc_release(ctx, irritants, s_irr); sexp_gc_release2(ctx);
return exn; return exn;
} }
@ -60,15 +58,15 @@ static sexp env_cell(sexp e, sexp key) {
} }
static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) {
sexp_gc_var(ctx, cell, s_cell); sexp_gc_var1(cell);
cell = env_cell(e, key); cell = env_cell(e, key);
if (! cell) { if (! cell) {
sexp_gc_preserve(ctx, cell, s_cell); sexp_gc_preserve1(ctx, cell);
cell = sexp_cons(ctx, key, value); cell = sexp_cons(ctx, key, value);
while (sexp_env_parent(e)) while (sexp_env_parent(e))
e = sexp_env_parent(e); e = sexp_env_parent(e);
sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e)); sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e));
sexp_gc_release(ctx, cell, s_cell); sexp_gc_release1(ctx);
} }
return cell; return cell;
} }
@ -83,26 +81,24 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) {
void env_define(sexp ctx, sexp e, sexp key, sexp value) { void env_define(sexp ctx, sexp e, sexp key, sexp value) {
sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e));
sexp_gc_var1(tmp);
if (sexp_immutablep(e)) { if (sexp_immutablep(e)) {
fprintf(stderr, "ERROR: immutable environment\n"); fprintf(stderr, "ERROR: immutable environment\n");
} else { } else {
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve1(ctx, tmp);
sexp_gc_preserve(ctx, tmp, s_tmp);
if (sexp_truep(cell)) if (sexp_truep(cell))
sexp_cdr(cell) = value; sexp_cdr(cell) = value;
else { else {
tmp = sexp_cons(ctx, key, value); tmp = sexp_cons(ctx, key, value);
sexp_push(ctx, sexp_env_bindings(e), tmp); sexp_push(ctx, sexp_env_bindings(e), tmp);
} }
sexp_gc_release(ctx, tmp, s_tmp); sexp_gc_release1(ctx);
} }
} }
static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
sexp_gc_var(ctx, e, s_e); sexp_gc_var2(e, tmp);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve2(ctx, e, tmp);
sexp_gc_preserve(ctx, e, s_e);
sexp_gc_preserve(ctx, tmp, s_tmp);
e = sexp_alloc_type(ctx, env, SEXP_ENV); e = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_parent(e) = env; sexp_env_parent(e) = env;
sexp_env_bindings(e) = SEXP_NULL; sexp_env_bindings(e) = SEXP_NULL;
@ -110,13 +106,13 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
tmp = sexp_cons(ctx, sexp_car(vars), value); tmp = sexp_cons(ctx, sexp_car(vars), value);
sexp_push(ctx, sexp_env_bindings(e), tmp); sexp_push(ctx, sexp_env_bindings(e), tmp);
} }
sexp_gc_release(ctx, e, s_e); sexp_gc_release2(ctx);
return e; return e;
} }
static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
res = env2; res = env2;
if (env1 && sexp_envp(env1)) { if (env1 && sexp_envp(env1)) {
res = sexp_alloc_type(ctx, env, SEXP_ENV); res = sexp_alloc_type(ctx, env, SEXP_ENV);
@ -124,16 +120,16 @@ static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) {
sexp_env_bindings(res) = sexp_env_bindings(env1); sexp_env_bindings(res) = sexp_env_bindings(env1);
sexp_env_lambda(res) = sexp_env_lambda(env1); sexp_env_lambda(res) = sexp_env_lambda(env1);
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls)); sexp_push(ctx, res, sexp_car(ls));
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res));
} }
@ -285,8 +281,8 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE)
sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
sexp_gc_var(ctx, res, save_res); sexp_gc_var1(res);
if (ctx) sexp_gc_preserve(ctx, res, save_res); if (ctx) sexp_gc_preserve1(ctx, res);
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
if ((! stack) || (stack == SEXP_FALSE)) { if ((! stack) || (stack == SEXP_FALSE)) {
stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
@ -311,7 +307,7 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
sexp_context_top(res) = 0; sexp_context_top(res) = 0;
sexp_context_tailp(res) = 1; sexp_context_tailp(res) = 1;
sexp_context_tracep(res) = 0; sexp_context_tracep(res) = 0;
if (ctx) sexp_gc_release(ctx, res, save_res); if (ctx) sexp_gc_release1(ctx);
return res; return res;
} }
@ -338,10 +334,8 @@ static sexp sexp_syntactic_closure_expr (sexp ctx, sexp x) {
static sexp sexp_strip_synclos (sexp ctx, sexp x) { static sexp sexp_strip_synclos (sexp ctx, sexp x) {
sexp res; sexp res;
sexp_gc_var(ctx, kar, s_kar); sexp_gc_var2(kar, kdr);
sexp_gc_var(ctx, kdr, s_kdr); sexp_gc_preserve2(ctx, kar, kdr);
sexp_gc_preserve(ctx, kar, s_kar);
sexp_gc_preserve(ctx, kdr, s_kdr);
loop: loop:
if (sexp_synclop(x)) { if (sexp_synclop(x)) {
x = sexp_synclo_expr(x); x = sexp_synclo_expr(x);
@ -354,7 +348,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
} else { } else {
res = x; res = x;
} }
sexp_gc_release(ctx, kar, s_kar); sexp_gc_release2(ctx);
return res; return res;
} }
@ -380,10 +374,8 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) {
/************************* the compiler ***************************/ /************************* the compiler ***************************/
static sexp analyze_app (sexp ctx, sexp x) { static sexp analyze_app (sexp ctx, sexp x) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var2(res, tmp);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve2(ctx, res, tmp);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, tmp, s_tmp);
for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
sexp_push(ctx, res, SEXP_FALSE); sexp_push(ctx, res, SEXP_FALSE);
tmp = analyze(ctx, sexp_car(x)); tmp = analyze(ctx, sexp_car(x));
@ -394,15 +386,13 @@ static sexp analyze_app (sexp ctx, sexp x) {
sexp_car(res) = tmp; sexp_car(res) = tmp;
} }
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release2(ctx);
return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
} }
static sexp analyze_seq (sexp ctx, sexp ls) { static sexp analyze_seq (sexp ctx, sexp ls) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var2(res, tmp);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve2(ctx, res, tmp);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, tmp, s_tmp);
if (sexp_nullp(ls)) if (sexp_nullp(ls))
res = SEXP_VOID; res = SEXP_VOID;
else if (sexp_nullp(sexp_cdr(ls))) else if (sexp_nullp(sexp_cdr(ls)))
@ -415,14 +405,14 @@ static sexp analyze_seq (sexp ctx, sexp ls) {
else else
sexp_seq_ls(res) = tmp; sexp_seq_ls(res) = tmp;
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release2(ctx);
return res; return res;
} }
static sexp analyze_var_ref (sexp ctx, sexp x) { static sexp analyze_var_ref (sexp ctx, sexp x) {
sexp env = sexp_context_env(ctx), res; sexp env = sexp_context_env(ctx), res;
sexp_gc_var(ctx, cell, s_cell); sexp_gc_var1(cell);
sexp_gc_preserve(ctx, cell, s_cell); sexp_gc_preserve1(ctx, cell);
cell = env_cell(env, x); cell = env_cell(env, x);
if (! cell) { if (! cell) {
if (sexp_synclop(x)) { if (sexp_synclop(x)) {
@ -436,16 +426,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) {
res = sexp_compile_error(ctx, "invalid use of syntax as value", x); res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
else else
res = sexp_make_ref(ctx, x, cell); res = sexp_make_ref(ctx, x, cell);
sexp_gc_release(ctx, cell, s_cell); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp analyze_set (sexp ctx, sexp x) { static sexp analyze_set (sexp ctx, sexp x) {
sexp res; sexp res;
sexp_gc_var(ctx, ref, s_ref); sexp_gc_var2(ref, value);
sexp_gc_var(ctx, value, s_value); sexp_gc_preserve2(ctx, ref, value);
sexp_gc_preserve(ctx, ref, s_ref);
sexp_gc_preserve(ctx, value, s_value);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
&& sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
res = sexp_compile_error(ctx, "bad set! syntax", x); res = sexp_compile_error(ctx, "bad set! syntax", x);
@ -461,7 +449,7 @@ static sexp analyze_set (sexp ctx, sexp x) {
else else
res = sexp_make_set(ctx, ref, value); res = sexp_make_set(ctx, ref, value);
} }
sexp_gc_release(ctx, ref, s_ref); sexp_gc_release2(ctx);
return res; return res;
} }
@ -469,18 +457,8 @@ static sexp analyze_set (sexp ctx, sexp x) {
static sexp analyze_lambda (sexp ctx, sexp x) { static sexp analyze_lambda (sexp ctx, sexp x) {
sexp name, ls; sexp name, ls;
sexp_gc_var(ctx, res, s_res); sexp_gc_var6(res, body, tmp, value, defs, ctx2);
sexp_gc_var(ctx, body, s_body); sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_var(ctx, value, s_value);
sexp_gc_var(ctx, defs, s_defs);
sexp_gc_var(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, body, s_body);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, value, s_value);
sexp_gc_preserve(ctx, defs, s_defs);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
/* verify syntax */ /* verify syntax */
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
@ -523,18 +501,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
} }
sexp_lambda_body(res) = body; sexp_lambda_body(res) = body;
cleanup: cleanup:
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp analyze_if (sexp ctx, sexp x) { static sexp analyze_if (sexp ctx, sexp x) {
sexp res, fail_expr; sexp res, fail_expr;
sexp_gc_var(ctx, test, s_test); sexp_gc_var3(test, pass, fail);
sexp_gc_var(ctx, pass, s_pass); sexp_gc_preserve3(ctx, test, pass, fail);
sexp_gc_var(ctx, fail, s_fail);
sexp_gc_preserve(ctx, test, s_test);
sexp_gc_preserve(ctx, pass, s_pass);
sexp_gc_preserve(ctx, fail, s_fail);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad if syntax", x); res = sexp_compile_error(ctx, "bad if syntax", x);
} else { } else {
@ -545,20 +519,14 @@ static sexp analyze_if (sexp ctx, sexp x) {
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
} }
sexp_gc_release(ctx, test, s_test); sexp_gc_release3(ctx);
return res; return res;
} }
static sexp analyze_define (sexp ctx, sexp x) { static sexp analyze_define (sexp ctx, sexp x) {
sexp name, res; sexp name, res;
sexp_gc_var(ctx, ref, s_ref); sexp_gc_var4(ref, value, tmp, env);
sexp_gc_var(ctx, value, s_value); sexp_gc_preserve4(ctx, ref, value, tmp, env);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_var(ctx, env, s_env);
sexp_gc_preserve(ctx, ref, s_ref);
sexp_gc_preserve(ctx, value, s_value);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, env, s_env);
env = sexp_context_env(ctx); env = sexp_context_env(ctx);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad define syntax", x); res = sexp_compile_error(ctx, "bad define syntax", x);
@ -591,18 +559,14 @@ static sexp analyze_define (sexp ctx, sexp x) {
res = sexp_make_set(ctx, ref, value); res = sexp_make_set(ctx, ref, value);
} }
} }
sexp_gc_release(ctx, ref, s_ref); sexp_gc_release4(ctx);
return res; return res;
} }
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
sexp res = SEXP_VOID, name; sexp res = SEXP_VOID, name;
sexp_gc_var(eval_ctx, proc, s_proc); sexp_gc_var3(proc, mac, tmp);
sexp_gc_var(eval_ctx, mac, s_mac); sexp_gc_preserve3(eval_ctx, proc, mac, tmp);
sexp_gc_var(eval_ctx, tmp, s_tmp);
sexp_gc_preserve(eval_ctx, proc, s_proc);
sexp_gc_preserve(eval_ctx, mac, s_mac);
sexp_gc_preserve(eval_ctx, tmp, s_tmp);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
&& sexp_nullp(sexp_cddar(ls)))) { && sexp_nullp(sexp_cddar(ls)))) {
@ -623,28 +587,24 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
} }
} }
} }
sexp_gc_release(eval_ctx, proc, s_proc); sexp_gc_release3(eval_ctx);
return res; return res;
} }
static sexp analyze_define_syntax (sexp ctx, sexp x) { static sexp analyze_define_syntax (sexp ctx, sexp x) {
sexp res; sexp res;
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var1(tmp);
sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve1(ctx, tmp);
tmp = sexp_list1(ctx, sexp_cdr(x)); tmp = sexp_list1(ctx, sexp_cdr(x));
res = analyze_bind_syntax(tmp, ctx, ctx); res = analyze_bind_syntax(tmp, ctx, ctx);
sexp_gc_release(ctx, tmp, s_tmp); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp analyze_let_syntax (sexp ctx, sexp x) { static sexp analyze_let_syntax (sexp ctx, sexp x) {
sexp res; sexp res;
sexp_gc_var(ctx, env, s_env); sexp_gc_var3(env, ctx2, tmp);
sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_preserve3(ctx, env, ctx2, tmp);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, env, s_env);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, tmp, s_tmp);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad let-syntax", x); res = sexp_compile_error(ctx, "bad let-syntax", x);
} else { } else {
@ -656,34 +616,28 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) {
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2);
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x)));
} }
sexp_gc_release(ctx, env, s_env); sexp_gc_release3(ctx);
return res; return res;
} }
static sexp analyze_letrec_syntax (sexp ctx, sexp x) { static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
sexp res; sexp res;
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var1(tmp);
sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve1(ctx, tmp);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad letrec-syntax", x); res = sexp_compile_error(ctx, "bad letrec-syntax", x);
} else { } else {
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx);
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x)));
} }
sexp_gc_release(ctx, tmp, s_tmp); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp analyze (sexp ctx, sexp object) { static sexp analyze (sexp ctx, sexp object) {
sexp op; sexp op;
sexp_gc_var(ctx, res, s_res); sexp_gc_var4(res, tmp, x, cell);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve4(ctx, res, tmp, x, cell);
sexp_gc_var(ctx, x, s_x);
sexp_gc_var(ctx, cell, s_cell);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, x, s_x);
sexp_gc_preserve(ctx, cell, s_cell);
x = object; x = object;
loop: loop:
if (sexp_pairp(x)) { if (sexp_pairp(x)) {
@ -771,7 +725,7 @@ static sexp analyze (sexp ctx, sexp object) {
} else { } else {
res = x; res = x;
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release4(ctx);
return res; return res;
} }
@ -898,8 +852,8 @@ static void generate_set (sexp ctx, sexp set) {
static void generate_opcode_app (sexp ctx, sexp app) { static void generate_opcode_app (sexp ctx, sexp app) {
sexp op = sexp_car(app); sexp op = sexp_car(app);
sexp_sint_t i, num_args; sexp_sint_t i, num_args;
sexp_gc_var(ctx, ls, s_ls); sexp_gc_var1(ls);
sexp_gc_preserve(ctx, ls, s_ls); sexp_gc_preserve1(ctx, ls);
num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app)));
sexp_context_tailp(ctx) = 0; sexp_context_tailp(ctx) = 0;
@ -977,14 +931,14 @@ static void generate_opcode_app (sexp ctx, sexp app) {
emit(ctx, sexp_opcode_code(op)); emit(ctx, sexp_opcode_code(op));
sexp_context_depth(ctx) -= (num_args-1); sexp_context_depth(ctx) -= (num_args-1);
sexp_gc_release(ctx, ls, s_ls); sexp_gc_release1(ctx);
} }
static void generate_general_app (sexp ctx, sexp app) { static void generate_general_app (sexp ctx, sexp app) {
sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))),
tailp = sexp_context_tailp(ctx); tailp = sexp_context_tailp(ctx);
sexp_gc_var(ctx, ls, s_ls); sexp_gc_var1(ls);
sexp_gc_preserve(ctx, ls, s_ls); sexp_gc_preserve1(ctx, ls);
/* push the arguments onto the stack */ /* push the arguments onto the stack */
sexp_context_tailp(ctx) = 0; sexp_context_tailp(ctx) = 0;
@ -999,7 +953,7 @@ static void generate_general_app (sexp ctx, sexp app) {
emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); emit_word(ctx, (sexp_uint_t)sexp_make_integer(len));
sexp_context_depth(ctx) -= len; sexp_context_depth(ctx) -= len;
sexp_gc_release(ctx, ls, s_ls); sexp_gc_release1(ctx);
} }
static void generate_app (sexp ctx, sexp app) { static void generate_app (sexp ctx, sexp app) {
@ -1012,10 +966,8 @@ static void generate_app (sexp ctx, sexp app) {
static void generate_lambda (sexp ctx, sexp lambda) { static void generate_lambda (sexp ctx, sexp lambda) {
sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
sexp_uint_t k; sexp_uint_t k;
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var2(tmp, bc);
sexp_gc_var(ctx, bc, s_bc); sexp_gc_preserve2(ctx, tmp, bc);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, bc, s_bc);
prev_lambda = sexp_context_lambda(ctx); prev_lambda = sexp_context_lambda(ctx);
prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
fv = sexp_lambda_fv(lambda); fv = sexp_lambda_fv(lambda);
@ -1073,7 +1025,7 @@ static void generate_lambda (sexp ctx, sexp lambda) {
emit_push(ctx, flags); emit_push(ctx, flags);
emit(ctx, OP_MAKE_PROCEDURE); emit(ctx, OP_MAKE_PROCEDURE);
} }
sexp_gc_release(ctx, tmp, s_tmp); sexp_gc_release2(ctx);
} }
static void generate (sexp ctx, sexp x) { static void generate (sexp ctx, sexp x) {
@ -1103,34 +1055,32 @@ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) {
} }
static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
if (sexp_nullp(fv2)) if (sexp_nullp(fv2))
return fv1; return fv1;
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
res = insert_free_var(ctx, sexp_car(fv1), res); res = insert_free_var(ctx, sexp_car(fv1), res);
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
res = SEXP_NULL; res = SEXP_NULL;
for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
if ((sexp_ref_loc(sexp_car(fv)) != lambda) if ((sexp_ref_loc(sexp_car(fv)) != lambda)
|| (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
== SEXP_FALSE)) == SEXP_FALSE))
sexp_push(ctx, res, sexp_car(fv)); sexp_push(ctx, res, sexp_car(fv));
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp free_vars (sexp ctx, sexp x, sexp fv) { static sexp free_vars (sexp ctx, sexp x, sexp fv) {
sexp_gc_var(ctx, fv1, s_fv1); sexp_gc_var2(fv1, fv2);
sexp_gc_var(ctx, fv2, s_fv2); sexp_gc_preserve2(ctx, fv1, fv2);
sexp_gc_preserve(ctx, fv1, s_fv1);
sexp_gc_preserve(ctx, fv2, s_fv2);
fv1 = fv; fv1 = fv;
if (sexp_lambdap(x)) { if (sexp_lambdap(x)) {
fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
@ -1157,34 +1107,26 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) {
} else if (sexp_synclop(x)) { } else if (sexp_synclop(x)) {
fv1 = free_vars(ctx, sexp_synclo_expr(x), fv); fv1 = free_vars(ctx, sexp_synclo_expr(x), fv);
} }
sexp_gc_release(ctx, fv1, s_fv1); sexp_gc_release2(ctx);
return fv1; return fv1;
} }
static sexp make_param_list(sexp ctx, sexp_uint_t i) { static sexp make_param_list(sexp ctx, sexp_uint_t i) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
res = SEXP_NULL; res = SEXP_NULL;
for ( ; i>0; i--) for ( ; i>0; i--)
res = sexp_cons(ctx, sexp_make_integer(i), res); res = sexp_cons(ctx, sexp_make_integer(i), res);
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
sexp ls, bc, res, env; sexp ls, bc, res, env;
sexp_gc_var(ctx, params, s_params); sexp_gc_var5(params, ref, refs, lambda, ctx2);
sexp_gc_var(ctx, ref, s_ref);
sexp_gc_var(ctx, refs, s_refs);
sexp_gc_var(ctx, lambda, s_lambda);
sexp_gc_var(ctx, ctx2, s_ctx2);
if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
return sexp_opcode_proc(op); /* return before preserving */ return sexp_opcode_proc(op); /* return before preserving */
sexp_gc_preserve(ctx, params, s_params); sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2);
sexp_gc_preserve(ctx, ref, s_ref);
sexp_gc_preserve(ctx, refs, s_refs);
sexp_gc_preserve(ctx, lambda, s_lambda);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
params = make_param_list(ctx, i); params = make_param_list(ctx, i);
lambda = sexp_make_lambda(ctx, params); lambda = sexp_make_lambda(ctx, params);
ctx2 = sexp_make_child_context(ctx, lambda); ctx2 = sexp_make_child_context(ctx, lambda);
@ -1203,7 +1145,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
bc, SEXP_VOID); bc, SEXP_VOID);
if (i == sexp_opcode_num_args(op)) if (i == sexp_opcode_num_args(op))
sexp_opcode_proc(op) = res; sexp_opcode_proc(op) = res;
sexp_gc_release(ctx, params, s_params); sexp_gc_release5(ctx);
return res; return res;
} }
@ -1259,13 +1201,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
#if USE_BIGNUMS #if USE_BIGNUMS
sexp_lsint_t prod; sexp_lsint_t prod;
#endif #endif
sexp_gc_var3(self, tmp1, tmp2);
sexp_gc_preserve3(ctx, self, tmp1, tmp2);
fp = top - 4; fp = top - 4;
sexp_gc_var(ctx, self, s_self);
sexp_gc_var(ctx, tmp1, s_tmp1);
sexp_gc_var(ctx, tmp2, s_tmp2);
sexp_gc_preserve(ctx, self, s_self);
sexp_gc_preserve(ctx, tmp1, s_tmp1);
sexp_gc_preserve(ctx, tmp2, s_tmp2);
self = proc; self = proc;
loop: loop:
@ -1954,7 +1892,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
goto loop; goto loop;
end_loop: end_loop:
sexp_gc_release(ctx, self, s_self); sexp_gc_release3(ctx);
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
return _ARG1; return _ARG1;
} }
@ -2024,14 +1962,8 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) {
sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp sexp_load (sexp ctx, sexp source, sexp env) {
sexp tmp, out; sexp tmp, out;
sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_var4(ctx2, x, in, res);
sexp_gc_var(ctx, x, s_x); sexp_gc_preserve4(ctx, ctx2, x, in, res);
sexp_gc_var(ctx, in, s_in);
sexp_gc_var(ctx, res, s_res);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, x, s_x);
sexp_gc_preserve(ctx, in, s_in);
sexp_gc_preserve(ctx, res, s_res);
res = SEXP_VOID; res = SEXP_VOID;
in = sexp_open_input_file(ctx, source); in = sexp_open_input_file(ctx, source);
out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
@ -2061,7 +1993,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out);
#endif #endif
} }
sexp_gc_release(ctx, ctx2, s_ctx2); sexp_gc_release4(ctx);
return res; return res;
} }
@ -2222,14 +2154,8 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) {
static sexp sexp_make_standard_env (sexp ctx, sexp version) { static sexp sexp_make_standard_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp ctx2, cell, sym, perr_cell, err_cell; sexp ctx2, cell, sym, perr_cell, err_cell;
sexp_gc_var(ctx, e, s_e); sexp_gc_var4(e, op, tmp, err_handler);
sexp_gc_var(ctx, op, s_op); sexp_gc_preserve4(ctx, e, op, tmp, err_handler);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_var(ctx, err_handler, s_err);
sexp_gc_preserve(ctx, e, s_e);
sexp_gc_preserve(ctx, op, s_op);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, err_handler, s_err);
e = sexp_make_null_env(ctx, version); e = sexp_make_null_env(ctx, version);
for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
op = sexp_copy_opcode(ctx, &opcodes[i]); op = sexp_copy_opcode(ctx, &opcodes[i]);
@ -2272,7 +2198,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
finalize_bytecode(ctx2), finalize_bytecode(ctx2),
tmp); tmp);
env_define(ctx2, e, the_err_handler_symbol, err_handler); env_define(ctx2, e, the_err_handler_symbol, err_handler);
sexp_gc_release(ctx, e, s_e); sexp_gc_release4(ctx);
return e; return e;
} }
@ -2314,14 +2240,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
} }
sexp sexp_compile (sexp ctx, sexp x) { sexp sexp_compile (sexp ctx, sexp x) {
sexp_gc_var(ctx, ast, s_ast); sexp_gc_var4(ast, ctx2, vec, res);
sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_preserve4(ctx, ast, ctx2, vec, res);
sexp_gc_var(ctx, vec, s_vec);
sexp_gc_var(ctx, res, s_res);
sexp_gc_preserve(ctx, ast, s_ast);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, vec, s_vec);
sexp_gc_preserve(ctx, res, s_res);
ast = analyze(ctx, x); ast = analyze(ctx, x);
if (sexp_exceptionp(ast)) { if (sexp_exceptionp(ast)) {
res = ast; res = ast;
@ -2333,14 +2253,14 @@ sexp sexp_compile (sexp ctx, sexp x) {
res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
res, vec); res, vec);
} }
sexp_gc_release(ctx, ast, s_ast); sexp_gc_release4(ctx);
return res; return res;
} }
sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
sexp res, ctx2; sexp res, ctx2;
sexp_gc_var(ctx, thunk, s_thunk); sexp_gc_var1(thunk);
sexp_gc_preserve(ctx, thunk, s_thunk); sexp_gc_preserve1(ctx, thunk);
ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
sexp_context_parent(ctx2) = ctx; sexp_context_parent(ctx2) = ctx;
thunk = sexp_compile(ctx2, obj); thunk = sexp_compile(ctx2, obj);
@ -2353,17 +2273,17 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
} else { } else {
res = sexp_apply(ctx2, thunk, SEXP_NULL); res = sexp_apply(ctx2, thunk, SEXP_NULL);
} }
sexp_gc_release(ctx, thunk, s_thunk); sexp_gc_release1(ctx);
return res; return res;
} }
sexp sexp_eval_string (sexp ctx, char *str, sexp env) { sexp sexp_eval_string (sexp ctx, char *str, sexp env) {
sexp res; sexp res;
sexp_gc_var(ctx, obj, s_obj); sexp_gc_var1(obj);
sexp_gc_preserve(ctx, obj, s_obj); sexp_gc_preserve1(ctx, obj);
obj = sexp_read_from_string(ctx, str); obj = sexp_read_from_string(ctx, str);
res = sexp_eval(ctx, obj, env); res = sexp_eval(ctx, obj, env);
sexp_gc_release(ctx, obj, s_obj); sexp_gc_release1(ctx);
return res; return res;
} }

21
include/chibi/sexp.h
View file

@ -293,6 +293,27 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#endif #endif
#endif #endif
#define sexp_gc_var1(x) sexp_gc_var(ctx, x, __sexp_gc_preserver1)
#define sexp_gc_var2(x, y) sexp_gc_var1(x); sexp_gc_var(ctx, y, __sexp_gc_preserver2)
#define sexp_gc_var3(x, y, z) sexp_gc_var2(x, y); sexp_gc_var(ctx, z, __sexp_gc_preserver3)
#define sexp_gc_var4(x, y, z, w) sexp_gc_var3(x, y, z); sexp_gc_var(ctx, w, __sexp_gc_preserver4)
#define sexp_gc_var5(x, y, z, w, v) sexp_gc_var4(x, y, z, w); sexp_gc_var(ctx, v, __sexp_gc_preserver5)
#define sexp_gc_var6(x, y, z, w, v, u) sexp_gc_var5(x, y, z, w, v); sexp_gc_var(ctx, u, __sexp_gc_preserver6)
#define sexp_gc_preserve1(ctx, x) sexp_gc_preserve(ctx, x, __sexp_gc_preserver1)
#define sexp_gc_preserve2(ctx, x, y) sexp_gc_preserve1(ctx, x); sexp_gc_preserve(ctx, y, __sexp_gc_preserver2)
#define sexp_gc_preserve3(ctx, x, y, z) sexp_gc_preserve2(ctx, x, y); sexp_gc_preserve(ctx, z, __sexp_gc_preserver3)
#define sexp_gc_preserve4(ctx, x, y, z, w) sexp_gc_preserve3(ctx, x, y, z); sexp_gc_preserve(ctx, w, __sexp_gc_preserver4)
#define sexp_gc_preserve5(ctx, x, y, z, w, v) sexp_gc_preserve4(ctx, x, y, z, w); sexp_gc_preserve(ctx, v, __sexp_gc_preserver5)
#define sexp_gc_preserve6(ctx, x, y, z, w, v, u) sexp_gc_preserve5(ctx, x, y, z, w, v); sexp_gc_preserve(ctx, u, __sexp_gc_preserver6)
#define sexp_gc_release1(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release2(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release3(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release4(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release5(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release6(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \

90
opt/bignum.c
View file

@ -30,12 +30,8 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
sexp sexp_double_to_bignum (sexp ctx, double f) { sexp sexp_double_to_bignum (sexp ctx, double f) {
int sign; int sign;
sexp_gc_var(ctx, res, s_res); sexp_gc_var3(res, scale, tmp);
sexp_gc_var(ctx, scale, s_scale); sexp_gc_preserve3(ctx, res, scale, tmp);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, scale, s_scale);
sexp_gc_preserve(ctx, tmp, s_tmp);
res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0));
scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1));
sign = (f < 0 ? -1 : 1); sign = (f < 0 ? -1 : 1);
@ -45,7 +41,7 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
} }
sexp_bignum_sign(res) = sign; sexp_bignum_sign(res) = sign;
sexp_gc_release(ctx, res, s_res); sexp_gc_release3(ctx);
return res; return res;
} }
@ -187,8 +183,8 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
char sign, sexp_uint_t base) { char sign, sexp_uint_t base) {
int c, digit; int c, digit;
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
sexp_bignum_sign(res) = sign; sexp_bignum_sign(res) = sign;
sexp_bignum_data(res)[0] = init; sexp_bignum_data(res)[0] = init;
@ -209,7 +205,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
sexp_make_character(c), in); sexp_make_character(c), in);
} }
sexp_push_char(ctx, c, in); sexp_push_char(ctx, c, in);
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return sexp_bignum_normalize(res); return sexp_bignum_normalize(res);
} }
@ -224,10 +220,8 @@ static int log2i(int v) {
sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
int i, str_len, lg_base = log2i(base); int i, str_len, lg_base = log2i(base);
char *data; char *data;
sexp_gc_var(ctx, b, s_b); sexp_gc_var2(b, str);
sexp_gc_var(ctx, str, s_str); sexp_gc_preserve2(ctx, b, str);
sexp_gc_preserve(ctx, b, s_b);
sexp_gc_preserve(ctx, str, s_str);
b = sexp_copy_bignum(ctx, NULL, a, 0); b = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(b) = 1; sexp_bignum_sign(b) = 1;
i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
@ -242,31 +236,31 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
else if (sexp_bignum_sign(a) == -1) else if (sexp_bignum_sign(a) == -1)
data[--i] = '-'; data[--i] = '-';
sexp_write_string(ctx, data + i, out); sexp_write_string(ctx, data + i, out);
sexp_gc_release(ctx, b, s_b); sexp_gc_release2(ctx);
return SEXP_VOID; return SEXP_VOID;
} }
/****************** bignum arithmetic *************************/ /****************** bignum arithmetic *************************/
sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
sexp_gc_var(ctx, c, s_c); sexp_gc_var1(c);
sexp_gc_preserve(ctx, c, s_c); sexp_gc_preserve1(ctx, c);
c = sexp_copy_bignum(ctx, NULL, a, 0); c = sexp_copy_bignum(ctx, NULL, a, 0);
if (sexp_bignum_sign(c) == sexp_fx_sign(b)) if (sexp_bignum_sign(c) == sexp_fx_sign(b))
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b)));
else else
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b)));
sexp_gc_release(ctx, c, s_c); sexp_gc_release1(ctx);
return c; return c;
} }
sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
borrow=0, i, *adata, *bdata, *cdata; borrow=0, i, *adata, *bdata, *cdata;
sexp_gc_var(ctx, c, s_c); sexp_gc_var1(c);
if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0)))
return sexp_bignum_sub_digits(ctx, dst, b, a); return sexp_bignum_sub_digits(ctx, dst, b, a);
sexp_gc_preserve(ctx, c, s_c); sexp_gc_preserve1(ctx, c);
c = ((dst && sexp_bignum_hi(dst) >= alen) c = ((dst && sexp_bignum_hi(dst) >= alen)
? dst : sexp_copy_bignum(ctx, NULL, a, 0)); ? dst : sexp_copy_bignum(ctx, NULL, a, 0));
adata = sexp_bignum_data(a); adata = sexp_bignum_data(a);
@ -280,16 +274,16 @@ sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
borrow = (cdata[i] == 0 ? 1 : 0); borrow = (cdata[i] == 0 ? 1 : 0);
cdata[i]--; cdata[i]--;
} }
sexp_gc_release(ctx, c, s_c); sexp_gc_release1(ctx);
return c; return c;
} }
sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
carry=0, i, n, *adata, *bdata, *cdata; carry=0, i, n, *adata, *bdata, *cdata;
sexp_gc_var(ctx, c, s_c); sexp_gc_var1(c);
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a); if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
sexp_gc_preserve(ctx, c, s_c); sexp_gc_preserve1(ctx, c);
c = ((dst && sexp_bignum_hi(dst) >= alen) c = ((dst && sexp_bignum_hi(dst) >= alen)
? dst : sexp_copy_bignum(ctx, NULL, a, 0)); ? dst : sexp_copy_bignum(ctx, NULL, a, 0));
adata = sexp_bignum_data(a); adata = sexp_bignum_data(a);
@ -308,7 +302,7 @@ sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
c = sexp_copy_bignum(ctx, NULL, c, alen+1); c = sexp_copy_bignum(ctx, NULL, c, alen+1);
sexp_bignum_data(c)[alen] = 1; sexp_bignum_data(c)[alen] = 1;
} }
sexp_gc_release(ctx, c, s_c); sexp_gc_release1(ctx);
return c; return c;
} }
@ -342,11 +336,9 @@ sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) {
sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i,
*bdata=sexp_bignum_data(b); *bdata=sexp_bignum_data(b);
sexp_gc_var(ctx, c, s_c); sexp_gc_var2(c, d);
sexp_gc_var(ctx, d, s_d);
if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a);
sexp_gc_preserve(ctx, c, s_c); sexp_gc_preserve2(ctx, c, d);
sexp_gc_preserve(ctx, d, s_d);
c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1));
d = sexp_make_bignum(ctx, alen+blen+1); d = sexp_make_bignum(ctx, alen+blen+1);
for (i=0; i<blen; i++) { for (i=0; i<blen; i++) {
@ -355,7 +347,7 @@ sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_bignum_data(d)[i] = 0; sexp_bignum_data(d)[i] = 0;
} }
sexp_bignum_sign(c) = sexp_bignum_sign(a) * sexp_bignum_sign(b); sexp_bignum_sign(c) = sexp_bignum_sign(a) * sexp_bignum_sign(b);
sexp_gc_release(ctx, c, s_c); sexp_gc_release2(ctx);
return c; return c;
} }
@ -365,20 +357,12 @@ static sexp sexp_bignum_double (sexp ctx, sexp a) {
static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) {
sexp res; sexp res;
sexp_gc_var(ctx, x, s_x); sexp_gc_var5(x, prod, diff, k2, i2);
sexp_gc_var(ctx, prod, s_prod);
sexp_gc_var(ctx, diff, s_diff);
sexp_gc_var(ctx, k2, s_k2);
sexp_gc_var(ctx, i2, s_i2);
if (sexp_bignum_compare(k, a) > 0) { if (sexp_bignum_compare(k, a) > 0) {
*rem = a; *rem = a;
return sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); return sexp_fixnum_to_bignum(ctx, sexp_make_integer(0));
} }
sexp_gc_preserve(ctx, x, s_x); sexp_gc_preserve5(ctx, x, prod, diff, k2, i2);
sexp_gc_preserve(ctx, prod, s_prod);
sexp_gc_preserve(ctx, diff, s_diff);
sexp_gc_preserve(ctx, k2, s_k2);
sexp_gc_preserve(ctx, i2, s_i2);
k2 = sexp_bignum_double(ctx, k); k2 = sexp_bignum_double(ctx, k);
i2 = sexp_bignum_double(ctx, i); i2 = sexp_bignum_double(ctx, i);
x = quot_step(ctx, rem, a, b, k2, i2); x = quot_step(ctx, rem, a, b, k2, i2);
@ -391,20 +375,14 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) {
*rem = diff; *rem = diff;
res = x; res = x;
} }
sexp_gc_release(ctx, x, s_x); sexp_gc_release5(ctx);
return res; return res;
} }
sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
sexp res; sexp res;
sexp_gc_var(ctx, k, s_k); sexp_gc_var4(k, i, a1, b1);
sexp_gc_var(ctx, i, s_i); sexp_gc_preserve4(ctx, k, i, a1, b1);
sexp_gc_var(ctx, a1, s_a1);
sexp_gc_var(ctx, b1, s_b1);
sexp_gc_preserve(ctx, k, s_k);
sexp_gc_preserve(ctx, i, s_i);
sexp_gc_preserve(ctx, a1, s_a1);
sexp_gc_preserve(ctx, b1, s_b1);
a1 = sexp_copy_bignum(ctx, NULL, a, 0); a1 = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(a1) = 1; sexp_bignum_sign(a1) = 1;
b1 = sexp_copy_bignum(ctx, NULL, b, 0); b1 = sexp_copy_bignum(ctx, NULL, b, 0);
@ -416,16 +394,16 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
if (sexp_bignum_sign(a) < 0) { if (sexp_bignum_sign(a) < 0) {
sexp_negate(*rem); sexp_negate(*rem);
} }
sexp_gc_release(ctx, k, s_k); sexp_gc_release4(ctx);
return res; return res;
} }
sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) {
sexp res; sexp res;
sexp_gc_var(ctx, rem, s_rem); sexp_gc_var1(rem);
sexp_gc_preserve(ctx, rem, s_rem); sexp_gc_preserve1(ctx, rem);
res = sexp_bignum_quot_rem(ctx, &rem, a, b); res = sexp_bignum_quot_rem(ctx, &rem, a, b);
sexp_gc_release(ctx, rem, s_rem); sexp_gc_release1(ctx);
return res; return res;
} }
@ -437,16 +415,14 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
sexp_sint_t e = sexp_unbox_integer(sexp_fx_abs(b)); sexp_sint_t e = sexp_unbox_integer(sexp_fx_abs(b));
sexp_gc_var(ctx, res, s_res); sexp_gc_var2(res, acc);
sexp_gc_var(ctx, acc, s_acc); sexp_gc_preserve2(ctx, res, acc);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, acc, s_acc);
res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1));
acc = sexp_copy_bignum(ctx, NULL, a, 0); acc = sexp_copy_bignum(ctx, NULL, a, 0);
for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
if (e & 1) if (e & 1)
res = sexp_bignum_mul(ctx, NULL, res, acc); res = sexp_bignum_mul(ctx, NULL, res, acc);
sexp_gc_release(ctx, res, s_res); sexp_gc_release2(ctx);
return res; return res;
} }

112
sexp.c
View file

@ -120,48 +120,38 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) { sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) {
sexp res; sexp res;
sexp_gc_var(ctx, sym, s_sym); sexp_gc_var3(sym, str, irr);
sexp_gc_var(ctx, str, s_str); sexp_gc_preserve3(ctx, sym, str, irr);
sexp_gc_var(ctx, irr, s_irr);
sexp_gc_preserve(ctx, sym, s_sym);
sexp_gc_preserve(ctx, str, s_str);
sexp_gc_preserve(ctx, irr, s_irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"), res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"),
str = sexp_c_string(ctx, message, -1), str = sexp_c_string(ctx, message, -1),
((sexp_pairp(irritants) || sexp_nullp(irritants)) ((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : (irr = sexp_list1(ctx, irritants))), ? irritants : (irr = sexp_list1(ctx, irritants))),
self, SEXP_FALSE); self, SEXP_FALSE);
sexp_gc_release(ctx, sym, s_sym); sexp_gc_release3(ctx);
return res; return res;
} }
sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { sexp sexp_type_exception (sexp ctx, char *message, sexp obj) {
sexp res; sexp res;
sexp_gc_var(ctx, sym, s_sym); sexp_gc_var3(sym, str, irr);
sexp_gc_var(ctx, str, s_str); sexp_gc_preserve3(ctx, sym, str, irr);
sexp_gc_var(ctx, irr, s_irr);
sexp_gc_preserve(ctx, sym, s_sym);
sexp_gc_preserve(ctx, str, s_str);
sexp_gc_preserve(ctx, irr, s_irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"), res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"),
str = sexp_c_string(ctx, message, -1), str = sexp_c_string(ctx, message, -1),
irr = sexp_list1(ctx, obj), irr = sexp_list1(ctx, obj),
SEXP_FALSE, SEXP_FALSE); SEXP_FALSE, SEXP_FALSE);
sexp_gc_release(ctx, sym, s_sym); sexp_gc_release3(ctx);
return res; return res;
} }
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var2(res, msg);
sexp_gc_var(ctx, msg, s_msg); sexp_gc_preserve2(ctx, res, msg);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, msg, s_msg);
msg = sexp_c_string(ctx, "bad index range", -1); msg = sexp_c_string(ctx, "bad index range", -1);
res = sexp_list2(ctx, start, end); res = sexp_list2(ctx, start, end);
res = sexp_cons(ctx, obj, res); res = sexp_cons(ctx, obj, res);
res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res, res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res,
SEXP_FALSE, SEXP_FALSE); SEXP_FALSE, SEXP_FALSE);
sexp_gc_release(ctx, res, s_res); sexp_gc_release2(ctx);
return res; return res;
} }
@ -225,12 +215,8 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
sexp res; sexp res;
sexp_gc_var(ctx, name, s_name); sexp_gc_var3(name, str, irr);
sexp_gc_var(ctx, str, s_str); sexp_gc_preserve3(ctx, name, str, irr);
sexp_gc_var(ctx, irr, s_irr);
sexp_gc_preserve(ctx, name, s_name);
sexp_gc_preserve(ctx, str, s_str);
sexp_gc_preserve(ctx, irr, s_irr);
name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE);
name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port))); name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port)));
str = sexp_c_string(ctx, msg, -1); str = sexp_c_string(ctx, msg, -1);
@ -238,7 +224,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
? irritants : sexp_list1(ctx, irritants)); ? irritants : sexp_list1(ctx, irritants));
res = sexp_make_exception(ctx, the_read_error_symbol, res = sexp_make_exception(ctx, the_read_error_symbol,
str, irr, SEXP_FALSE, name); str, irr, SEXP_FALSE, name);
sexp_gc_release(ctx, name, s_name); sexp_gc_release3(ctx);
return res; return res;
} }
@ -253,11 +239,11 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) {
} }
sexp sexp_list2 (sexp ctx, sexp a, sexp b) { sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
res = sexp_cons(ctx, b, SEXP_NULL); res = sexp_cons(ctx, b, SEXP_NULL);
res = sexp_cons(ctx, a, res); res = sexp_cons(ctx, a, res);
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
@ -294,11 +280,11 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) {
} }
sexp sexp_reverse (sexp ctx, sexp ls) { sexp sexp_reverse (sexp ctx, sexp ls) {
sexp_gc_var(ctx, res, s_res); sexp_gc_var1(res);
sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve1(ctx, res);
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(ctx, sexp_car(ls), res); res = sexp_cons(ctx, sexp_car(ls), res);
sexp_gc_release(ctx, res, s_res); sexp_gc_release1(ctx);
return res; return res;
} }
@ -321,14 +307,12 @@ sexp sexp_nreverse (sexp ctx, sexp ls) {
} }
sexp sexp_append2 (sexp ctx, sexp a, sexp b) { sexp sexp_append2 (sexp ctx, sexp a, sexp b) {
sexp_gc_var(ctx, a1, s_a1); sexp_gc_var2(a1, b1);
sexp_gc_var(ctx, b1, s_b1); sexp_gc_preserve2(ctx, a1, b1);
sexp_gc_preserve(ctx, a1, s_a1);
sexp_gc_preserve(ctx, b1, s_b1);
b1 = b; b1 = b;
for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1))
b1 = sexp_cons(ctx, sexp_car(a1), b1); b1 = sexp_cons(ctx, sexp_car(a1), b1);
sexp_gc_release(ctx, a1, s_a1); sexp_gc_release2(ctx);
return b1; return b1;
} }
@ -493,7 +477,7 @@ sexp sexp_intern(sexp ctx, char *str) {
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket;
char c, *p=str; char c, *p=str;
sexp ls; sexp ls;
sexp_gc_var(ctx, sym, s_sym); sexp_gc_var1(sym);
#if USE_HUFF_SYMS #if USE_HUFF_SYMS
res = 0; res = 0;
@ -521,11 +505,11 @@ sexp sexp_intern(sexp ctx, char *str) {
return sexp_car(ls); return sexp_car(ls);
/* not found, make a new symbol */ /* not found, make a new symbol */
sexp_gc_preserve(ctx, sym, s_sym); sexp_gc_preserve1(ctx, sym);
sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL);
sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_symbol_string(sym) = sexp_c_string(ctx, str, len);
sexp_push(ctx, sexp_symbol_table[bucket], sym); sexp_push(ctx, sexp_symbol_table[bucket], sym);
sexp_gc_release(ctx, sym, s_sym); sexp_gc_release1(ctx);
return sym; return sym;
} }
@ -625,8 +609,8 @@ off_t sstream_seek (void *vec, off_t offset, int whence) {
sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp sexp_make_input_string_port (sexp ctx, sexp str) {
FILE *in; FILE *in;
sexp res; sexp res;
sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_var1(cookie);
sexp_gc_preserve(ctx, cookie, s_cookie); sexp_gc_preserve1(ctx, cookie);
cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID);
sexp_stream_ctx(cookie) = ctx; sexp_stream_ctx(cookie) = ctx;
sexp_stream_buf(cookie) = str; sexp_stream_buf(cookie) = str;
@ -635,15 +619,15 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) {
in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
res = sexp_make_input_port(ctx, in, SEXP_FALSE); res = sexp_make_input_port(ctx, in, SEXP_FALSE);
sexp_port_cookie(res) = cookie; sexp_port_cookie(res) = cookie;
sexp_gc_release(ctx, cookie, s_cookie); sexp_gc_release1(ctx);
return res; return res;
} }
sexp sexp_make_output_string_port (sexp ctx) { sexp sexp_make_output_string_port (sexp ctx) {
FILE *out; FILE *out;
sexp res, size; sexp res, size;
sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_var1(cookie);
sexp_gc_preserve(ctx, cookie, s_cookie); sexp_gc_preserve1(ctx, cookie);
size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE);
cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID);
sexp_stream_ctx(cookie) = ctx; sexp_stream_ctx(cookie) = ctx;
@ -653,7 +637,7 @@ sexp sexp_make_output_string_port (sexp ctx) {
out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
res = sexp_make_output_port(ctx, out, SEXP_FALSE); res = sexp_make_output_port(ctx, out, SEXP_FALSE);
sexp_port_cookie(res) = cookie; sexp_port_cookie(res) = cookie;
sexp_gc_release(ctx, cookie, s_cookie); sexp_gc_release1(ctx);
return res; return res;
} }
@ -727,7 +711,7 @@ sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) {
} }
sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var1(tmp);
if (! sexp_oportp(p)) if (! sexp_oportp(p))
return sexp_type_exception(ctx, "not an output-port", p); return sexp_type_exception(ctx, "not an output-port", p);
else if (! sexp_port_openp(p)) else if (! sexp_port_openp(p))
@ -737,10 +721,10 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) {
fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
fflush(sexp_port_stream(p)); fflush(sexp_port_stream(p));
} else if (sexp_port_offset(p) > 0) { } else if (sexp_port_offset(p) > 0) {
sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve1(ctx, tmp);
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
sexp_push(ctx, sexp_port_cookie(p), tmp); sexp_push(ctx, sexp_port_cookie(p), tmp);
sexp_gc_release(ctx, tmp, s_tmp); sexp_gc_release1(ctx);
} }
sexp_port_offset(p) = 0; sexp_port_offset(p) = 0;
return SEXP_VOID; return SEXP_VOID;
@ -767,10 +751,8 @@ sexp sexp_make_output_string_port (sexp ctx) {
sexp sexp_get_output_string (sexp ctx, sexp out) { sexp sexp_get_output_string (sexp ctx, sexp out) {
sexp res; sexp res;
sexp_gc_var(ctx, ls, s_ls); sexp_gc_var2(ls, tmp);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve2(ctx, ls, tmp);
sexp_gc_preserve(ctx, ls, s_ls);
sexp_gc_preserve(ctx, tmp, s_tmp);
if (sexp_port_offset(out) > 0) { if (sexp_port_offset(out) > 0) {
tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out));
ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); ls = sexp_cons(ctx, tmp, sexp_port_cookie(out));
@ -778,7 +760,7 @@ sexp sexp_get_output_string (sexp ctx, sexp out) {
ls = sexp_port_cookie(out); ls = sexp_port_cookie(out);
} }
res = sexp_string_concatenate(ctx, ls); res = sexp_string_concatenate(ctx, ls);
sexp_gc_release(ctx, ls, s_ls); sexp_gc_release2(ctx);
return res; return res;
} }
@ -1109,10 +1091,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
char *str; char *str;
int c1, c2, line; int c1, c2, line;
sexp tmp2; sexp tmp2;
sexp_gc_var(ctx, res, s_res); sexp_gc_var2(res, tmp);
sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve2(ctx, res, tmp);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, tmp, s_tmp);
scan_loop: scan_loop:
switch (c1 = sexp_read_char(ctx, in)) { switch (c1 = sexp_read_char(ctx, in)) {
@ -1355,7 +1335,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
if (sexp_port_sourcep(in) && sexp_pointerp(res)) if (sexp_port_sourcep(in) && sexp_pointerp(res))
sexp_immutablep(res) = 1; sexp_immutablep(res) = 1;
sexp_gc_release(ctx, res, s_res); sexp_gc_release2(ctx);
return res; return res;
} }
@ -1370,25 +1350,23 @@ sexp sexp_read (sexp ctx, sexp in) {
sexp sexp_read_from_string(sexp ctx, char *str) { sexp sexp_read_from_string(sexp ctx, char *str) {
sexp res; sexp res;
sexp_gc_var(ctx, s, s_s); sexp_gc_var2(s, in);
sexp_gc_var(ctx, in, s_in); sexp_gc_preserve2(ctx, s, in);
sexp_gc_preserve(ctx, s, s_s);
sexp_gc_preserve(ctx, in, s_in);
s = sexp_c_string(ctx, str, -1); s = sexp_c_string(ctx, str, -1);
in = sexp_make_input_string_port(ctx, s); in = sexp_make_input_string_port(ctx, s);
res = sexp_read(ctx, in); res = sexp_read(ctx, in);
sexp_gc_release(ctx, s, s_s); sexp_gc_release2(ctx);
return res; return res;
} }
sexp sexp_write_to_string(sexp ctx, sexp obj) { sexp sexp_write_to_string(sexp ctx, sexp obj) {
sexp str; sexp str;
sexp_gc_var(ctx, out, s_out); sexp_gc_var1(out);
sexp_gc_preserve(ctx, out, s_out); sexp_gc_preserve1(ctx, out);
out = sexp_make_output_string_port(ctx); out = sexp_make_output_string_port(ctx);
sexp_write(ctx, obj, out); sexp_write(ctx, obj, out);
str = sexp_get_output_string(ctx, out); str = sexp_get_output_string(ctx, out);
sexp_gc_release(ctx, out, s_out); sexp_gc_release1(ctx);
return str; return str;
} }