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

stack is now a data type (maybe merge w/ vector),

Browse source 
new gc seems initially functional
This commit is contained in:
Alex Shinn 2009-06-08 02:06:24 +09:00
parent 378cdff8e3
commit d65e7255f8
5 changed files with 432 additions and 165 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme
LDFLAGS=-lm LDFLAGS=-lm
# -Oz for smaller size on darwin # -Oz for smaller size on darwin
CFLAGS=-Wall -g -Os -save-temps CFLAGS=-Wall -g -save-temps
#GC_OBJ=./gc/gc.a #GC_OBJ=./gc/gc.a
GC_OBJ= GC_OBJ=
@ -20,7 +20,7 @@ GC_OBJ=
./gc/gc.a: ./gc/alloc.c ./gc/gc.a: ./gc/alloc.c
cd gc && make cd gc && make
sexp.o: sexp.c sexp.h config.h defaults.h Makefile sexp.o: sexp.c gc.c sexp.h config.h defaults.h Makefile
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile

211
eval.c
View file

@ -8,7 +8,7 @@
static int scheme_initialized_p = 0; static int scheme_initialized_p = 0;
static sexp continuation_resumer, final_resumer; sexp continuation_resumer, final_resumer;
static sexp the_interaction_env_symbol; static sexp the_interaction_env_symbol;
static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_err_handler_symbol, the_compile_error_symbol;
static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
@ -89,7 +89,6 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp 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_release(ctx, e, s_e);
sexp_gc_release(ctx, tmp, s_tmp);
return e; return e;
} }
@ -247,12 +246,16 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
return res; return res;
} }
static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
sexp_gc_var(ctx, res, save_res); sexp_gc_var(ctx, res, save_res);
if (ctx) sexp_gc_preserve(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res);
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
sexp_context_stack(res) if ((! stack) || (stack == SEXP_FALSE)) {
= (stack ? stack : (sexp*) sexp_alloc(res, sizeof(sexp)*INIT_STACK_SIZE)); stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK);
sexp_stack_length(stack) = INIT_STACK_SIZE;
sexp_stack_top(stack) = 0;
}
sexp_context_stack(res) = stack;
sexp_context_env(res) sexp_context_env(res)
= (env ? env : sexp_make_standard_env(res, sexp_make_integer(5))); = (env ? env : sexp_make_standard_env(res, sexp_make_integer(5)));
sexp_context_bc(res) sexp_context_bc(res)
@ -313,7 +316,6 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
res = x; res = x;
} }
sexp_gc_release(ctx, kar, s_kar); sexp_gc_release(ctx, kar, s_kar);
sexp_gc_release(ctx, kdr, s_kdr);
return res; return res;
} }
@ -434,7 +436,6 @@ 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_release(ctx, ref, s_ref);
sexp_gc_release(ctx, value, s_value);
return res; return res;
} }
@ -497,10 +498,6 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
} }
sexp_lambda_body(res) = body; sexp_lambda_body(res) = body;
sexp_gc_release(ctx, res, s_res); sexp_gc_release(ctx, res, s_res);
sexp_gc_release(ctx, body, s_body);
sexp_gc_release(ctx, tmp, s_tmp);
sexp_gc_release(ctx, value, s_value);
sexp_gc_release(ctx, defs, s_defs);
return res; return res;
} }
@ -518,8 +515,6 @@ static sexp analyze_if (sexp ctx, sexp x) {
analyze_bind(fail, fail_expr, ctx); analyze_bind(fail, fail_expr, ctx);
res = sexp_make_cnd(ctx, test, pass, fail); res = sexp_make_cnd(ctx, test, pass, fail);
sexp_gc_release(ctx, test, s_test); sexp_gc_release(ctx, test, s_test);
sexp_gc_release(ctx, pass, s_pass);
sexp_gc_release(ctx, fail, s_fail);
return res; return res;
} }
@ -556,8 +551,6 @@ static sexp analyze_define (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_release(ctx, ref, s_ref);
sexp_gc_release(ctx, value, s_value);
sexp_gc_release(ctx, tmp, s_tmp);
return res; return res;
} }
@ -578,8 +571,6 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
} }
} }
sexp_gc_release(eval_ctx, proc, s_proc); sexp_gc_release(eval_ctx, proc, s_proc);
sexp_gc_release(eval_ctx, mac, s_mac);
sexp_gc_release(eval_ctx, tmp, s_tmp);
return SEXP_VOID; return SEXP_VOID;
} }
@ -610,8 +601,6 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) {
analyze_check_exception(tmp); analyze_check_exception(tmp);
res = analyze_seq(ctx2, sexp_cddr(x)); res = analyze_seq(ctx2, sexp_cddr(x));
sexp_gc_release(ctx, env, s_env); sexp_gc_release(ctx, env, s_env);
sexp_gc_release(ctx, ctx2, s_ctx2);
sexp_gc_release(ctx, tmp, s_tmp);
return res; return res;
} }
@ -711,8 +700,6 @@ static sexp analyze (sexp ctx, sexp object) {
res = x; res = x;
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release(ctx, res, s_res);
sexp_gc_release(ctx, tmp, s_tmp);
sexp_gc_release(ctx, x, s_x);
return res; return res;
} }
@ -1119,8 +1106,6 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
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_release(ctx, params, s_params);
sexp_gc_release(ctx, ref, s_ref);
sexp_gc_release(ctx, refs, s_refs);
return res; return res;
} }
@ -1155,7 +1140,10 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
#define _UWORD0 ((sexp_uint_t*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0]
#define _SWORD0 ((sexp_sint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0]
#define sexp_raise(msg, args) do {stack[top]=sexp_user_exception(context, self, msg, args); \ #define sexp_raise(msg, args) \
do {sexp_context_top(ctx) = top+1; \
stack[top] = args; \
stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \
top++; \ top++; \
goto call_error_handler;} \ goto call_error_handler;} \
while (0) while (0)
@ -1164,15 +1152,24 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
goto call_error_handler;} \ goto call_error_handler;} \
while (0) while (0)
sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { sexp vm (sexp proc, sexp ctx) {
sexp bc = sexp_procedure_code(self), cp = sexp_procedure_vars(self); sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc);
unsigned char *ip=sexp_bytecode_data(bc); sexp env = sexp_context_env(ctx),
sexp tmp1, tmp2, env=sexp_context_env(context); *stack = sexp_stack_data(sexp_context_stack(ctx));
sexp_sint_t i, j, k, fp=top-4; unsigned char *ip = sexp_bytecode_data(bc);
sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
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;
loop: loop:
#ifdef DEBUG_VM #ifdef DEBUG_VM
if (sexp_context_tracep(context)) { if (sexp_context_tracep(ctx)) {
sexp_print_stack(stack, top, fp, sexp_print_stack(stack, top, fp,
env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); env_global_ref(env, the_cur_err_symbol, SEXP_FALSE));
fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN");
@ -1213,8 +1210,9 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
stack[top+3] = sexp_make_integer(fp); stack[top+3] = sexp_make_integer(fp);
tmp1 = _ARG1; tmp1 = _ARG1;
i = 1; i = 1;
tmp2 = sexp_vector(context, 1, sexp_save_stack(context, stack, top+4)); sexp_context_top(ctx) = top;
_ARG1 = sexp_make_procedure(context, sexp_make_integer(0), tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4));
_ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0),
sexp_make_integer(1), continuation_resumer, sexp_make_integer(1), continuation_resumer,
tmp2); tmp2);
top++; top++;
@ -1223,7 +1221,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
case OP_APPLY1: case OP_APPLY1:
tmp1 = _ARG1; tmp1 = _ARG1;
tmp2 = _ARG2; tmp2 = _ARG2;
i = sexp_unbox_integer(sexp_length(context, tmp2)); i = sexp_unbox_integer(sexp_length(ctx, tmp2));
top += (i-2); top += (i-2);
for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
_ARG1 = sexp_car(tmp2); _ARG1 = sexp_car(tmp2);
@ -1256,29 +1254,31 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
make_call: make_call:
if (sexp_opcodep(tmp1)) { if (sexp_opcodep(tmp1)) {
/* compile non-inlined opcode applications on the fly */ /* compile non-inlined opcode applications on the fly */
sexp_context_top(context) = top; sexp_context_top(ctx) = top;
tmp1 = make_opcode_procedure(context, tmp1, i); tmp1 = make_opcode_procedure(ctx, tmp1, i);
if (sexp_exceptionp(tmp1)) { if (sexp_exceptionp(tmp1)) {
_ARG1 = tmp1; _ARG1 = tmp1;
goto call_error_handler; goto call_error_handler;
} }
} }
if (! sexp_procedurep(tmp1)) if (! sexp_procedurep(tmp1))
sexp_raise("non procedure application", sexp_list1(context, tmp1)); sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1));
if (j < 0) if (j < 0)
sexp_raise("not enough args", sexp_list2(context, tmp1, sexp_make_integer(i))); sexp_raise("not enough args",
sexp_list2(ctx, tmp1, sexp_make_integer(i)));
if (j > 0) { if (j > 0) {
if (sexp_procedure_variadic_p(tmp1)) { if (sexp_procedure_variadic_p(tmp1)) {
stack[top-i-1] = sexp_cons(context, stack[top-i-1], SEXP_NULL); stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL);
for (k=top-i; k<top-(i-j)-1; k++) for (k=top-i; k<top-(i-j)-1; k++)
stack[top-i-1] = sexp_cons(context, stack[k], stack[top-i-1]); stack[top-i-1] = sexp_cons(ctx, stack[k], stack[top-i-1]);
for ( ; k<top; k++) for ( ; k<top; k++)
stack[k-j+1] = stack[k]; stack[k-j+1] = stack[k];
top -= (j-1); top -= (j-1);
i -= (j-1); i -= (j-1);
} else { } else {
sexp_raise("too many args", sexp_list2(context, tmp1, sexp_make_integer(i))); sexp_raise("too many args",
sexp_list2(ctx, tmp1, sexp_make_integer(i)));
} }
} else if (sexp_procedure_variadic_p(tmp1)) { } else if (sexp_procedure_variadic_p(tmp1)) {
/* shift stack, set extra arg to null */ /* shift stack, set extra arg to null */
@ -1300,48 +1300,48 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
fp = top-4; fp = top-4;
break; break;
case OP_FCALL0: case OP_FCALL0:
_PUSH(((sexp_proc1)_UWORD0)(context)); _PUSH(((sexp_proc1)_UWORD0)(ctx));
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL1: case OP_FCALL1:
_ARG1 = ((sexp_proc2)_UWORD0)(context, _ARG1); _ARG1 = ((sexp_proc2)_UWORD0)(ctx, _ARG1);
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL2: case OP_FCALL2:
_ARG2 = ((sexp_proc3)_UWORD0)(context, _ARG1, _ARG2); _ARG2 = ((sexp_proc3)_UWORD0)(ctx, _ARG1, _ARG2);
top--; top--;
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL3: case OP_FCALL3:
_ARG3 =((sexp_proc4)_UWORD0)(context, _ARG1, _ARG2, _ARG3); _ARG3 =((sexp_proc4)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3);
top -= 2; top -= 2;
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL4: case OP_FCALL4:
_ARG4 =((sexp_proc5)_UWORD0)(context, _ARG1, _ARG2, _ARG3, _ARG4); _ARG4 =((sexp_proc5)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4);
top -= 3; top -= 3;
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL5: case OP_FCALL5:
_ARG5 =((sexp_proc6)_UWORD0)(context, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); _ARG5 =((sexp_proc6)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5);
top -= 4; top -= 4;
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_FCALL6: case OP_FCALL6:
_ARG6 =((sexp_proc7)_UWORD0)(context, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); _ARG6 =((sexp_proc7)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6);
top -= 5; top -= 5;
ip += sizeof(sexp); ip += sizeof(sexp);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_EVAL: case OP_EVAL:
sexp_context_top(context) = top; sexp_context_top(ctx) = top;
_ARG1 = eval_in_context(context, _ARG1); _ARG1 = eval_in_context(ctx, _ARG1);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
@ -1362,7 +1362,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break; break;
case OP_GLOBAL_REF: case OP_GLOBAL_REF:
if (sexp_cdr(_WORD0) == SEXP_UNDEF) if (sexp_cdr(_WORD0) == SEXP_UNDEF)
sexp_raise("undefined variable", sexp_list1(context, sexp_car(_WORD0))); sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0)));
/* ... FALLTHROUGH ... */ /* ... FALLTHROUGH ... */
case OP_GLOBAL_KNOWN_REF: case OP_GLOBAL_KNOWN_REF:
_PUSH(sexp_cdr(_WORD0)); _PUSH(sexp_cdr(_WORD0));
@ -1389,13 +1389,13 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break; break;
case OP_VECTOR_REF: case OP_VECTOR_REF:
if (! sexp_vectorp(_ARG1)) if (! sexp_vectorp(_ARG1))
sexp_raise("vector-ref: not a vector", sexp_list1(context, _ARG1)); sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
_ARG2 = sexp_vector_ref(_ARG1, _ARG2); _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
top--; top--;
break; break;
case OP_VECTOR_SET: case OP_VECTOR_SET:
if (! sexp_vectorp(_ARG1)) if (! sexp_vectorp(_ARG1))
sexp_raise("vector-set!: not a vector", sexp_list1(context, _ARG1)); sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
sexp_vector_set(_ARG1, _ARG2, _ARG3); sexp_vector_set(_ARG1, _ARG2, _ARG3);
_ARG3 = SEXP_VOID; _ARG3 = SEXP_VOID;
top-=2; top-=2;
@ -1416,11 +1416,11 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); _ARG1 = sexp_make_integer(sexp_string_length(_ARG1));
break; break;
case OP_MAKE_PROCEDURE: case OP_MAKE_PROCEDURE:
_ARG4 = sexp_make_procedure(context, _ARG1, _ARG2, _ARG3, _ARG4); _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4);
top-=3; top-=3;
break; break;
case OP_MAKE_VECTOR: case OP_MAKE_VECTOR:
_ARG2 = sexp_make_vector(context, _ARG1, _ARG2); _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
top--; top--;
break; break;
case OP_AND: case OP_AND:
@ -1444,27 +1444,30 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_CAR: case OP_CAR:
if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(context, _ARG1)); if (! sexp_pairp(_ARG1))
sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_car(_ARG1); break; _ARG1 = sexp_car(_ARG1); break;
case OP_CDR: case OP_CDR:
if (! sexp_pairp(_ARG1)) sexp_raise("cdr: not a pair", sexp_list1(context, _ARG1)); if (! sexp_pairp(_ARG1))
sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_cdr(_ARG1); break; _ARG1 = sexp_cdr(_ARG1); break;
case OP_SET_CAR: case OP_SET_CAR:
if (! sexp_pairp(_ARG1)) if (! sexp_pairp(_ARG1))
sexp_raise("set-car!: not a pair", sexp_list1(context, _ARG1)); sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1));
sexp_car(_ARG1) = _ARG2; sexp_car(_ARG1) = _ARG2;
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
break; break;
case OP_SET_CDR: case OP_SET_CDR:
if (! sexp_pairp(_ARG1)) if (! sexp_pairp(_ARG1))
sexp_raise("set-cdr!: not a pair", sexp_list1(context, _ARG1)); sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1));
sexp_cdr(_ARG1) = _ARG2; sexp_cdr(_ARG1) = _ARG2;
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
break; break;
case OP_CONS: case OP_CONS:
_ARG2 = sexp_cons(context, _ARG1, _ARG2); sexp_context_top(ctx) = top;
_ARG2 = sexp_cons(ctx, _ARG1, _ARG2);
top--; top--;
break; break;
case OP_ADD: case OP_ADD:
@ -1472,13 +1475,13 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_fx_add(_ARG1, _ARG2); _ARG2 = sexp_fx_add(_ARG1, _ARG2);
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_add(context, _ARG1, _ARG2); _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_add(context, _ARG1, sexp_integer_to_flonum(context, _ARG2)); _ARG2 = sexp_fp_add(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_add(context, sexp_integer_to_flonum(context, _ARG1), _ARG2); _ARG2 = sexp_fp_add(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
#endif #endif
else sexp_raise("+: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2));
top--; top--;
break; break;
case OP_SUB: case OP_SUB:
@ -1486,13 +1489,13 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_fx_sub(_ARG1, _ARG2); _ARG2 = sexp_fx_sub(_ARG1, _ARG2);
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_sub(context, _ARG1, _ARG2); _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_sub(context, _ARG1, sexp_integer_to_flonum(context, _ARG2)); _ARG2 = sexp_fp_sub(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_sub(context, sexp_integer_to_flonum(context, _ARG1), _ARG2); _ARG2 = sexp_fp_sub(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
#endif #endif
else sexp_raise("-: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2));
top--; top--;
break; break;
case OP_MUL: case OP_MUL:
@ -1500,31 +1503,31 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_fx_mul(_ARG1, _ARG2); _ARG2 = sexp_fx_mul(_ARG1, _ARG2);
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_mul(context, _ARG1, _ARG2); _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_mul(context, _ARG1, sexp_integer_to_flonum(context, _ARG2)); _ARG2 = sexp_fp_mul(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_mul(context, sexp_integer_to_flonum(context, _ARG1), _ARG2); _ARG2 = sexp_fp_mul(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
#endif #endif
else sexp_raise("*: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2));
top--; top--;
break; break;
case OP_DIV: case OP_DIV:
if (_ARG2 == sexp_make_integer(0)) if (_ARG2 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL); sexp_raise("divide by zero", SEXP_NULL);
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_div(context, _ARG2 = sexp_fp_div(ctx,
sexp_integer_to_flonum(context, _ARG1), sexp_integer_to_flonum(ctx, _ARG1),
sexp_integer_to_flonum(context, _ARG2)); sexp_integer_to_flonum(ctx, _ARG2));
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_div(context, _ARG1, _ARG2); _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_div(context, _ARG1, sexp_integer_to_flonum(context, _ARG2)); _ARG2 = sexp_fp_div(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
_ARG2 = sexp_fp_div(context, sexp_integer_to_flonum(context, _ARG1), _ARG2); _ARG2 = sexp_fp_div(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
#endif #endif
else sexp_raise("/: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2));
top--; top--;
break; break;
case OP_QUOTIENT: case OP_QUOTIENT:
@ -1534,7 +1537,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_fx_div(_ARG1, _ARG2); _ARG2 = sexp_fx_div(_ARG1, _ARG2);
top--; top--;
} }
else sexp_raise("quotient: not an integer", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2));
break; break;
case OP_REMAINDER: case OP_REMAINDER:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
@ -1544,25 +1547,25 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
top--; top--;
_ARG1 = tmp1; _ARG1 = tmp1;
} }
else sexp_raise("remainder: not an integer", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2));
break; break;
case OP_NEGATIVE: case OP_NEGATIVE:
if (sexp_integerp(_ARG1)) if (sexp_integerp(_ARG1))
_ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1));
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1)) else if (sexp_flonump(_ARG1))
_ARG1 = sexp_make_flonum(context, -sexp_flonum_value(_ARG1)); _ARG1 = sexp_make_flonum(ctx, -sexp_flonum_value(_ARG1));
#endif #endif
else sexp_raise("-: not a number", sexp_list1(context, _ARG1)); else sexp_raise("-: not a number", sexp_list1(ctx, _ARG1));
break; break;
case OP_INVERSE: case OP_INVERSE:
if (sexp_integerp(_ARG1)) if (sexp_integerp(_ARG1))
_ARG1 = sexp_make_flonum(context, 1/(double)sexp_unbox_integer(_ARG1)); _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_integer(_ARG1));
#if USE_FLONUMS #if USE_FLONUMS
else if (sexp_flonump(_ARG1)) else if (sexp_flonump(_ARG1))
_ARG1 = sexp_make_flonum(context, 1/sexp_flonum_value(_ARG1)); _ARG1 = sexp_make_flonum(ctx, 1/sexp_flonum_value(_ARG1));
#endif #endif
else sexp_raise("/: not a number", sexp_list1(context, _ARG1)); else sexp_raise("/: not a number", sexp_list1(ctx, _ARG1));
break; break;
case OP_LT: case OP_LT:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
@ -1575,7 +1578,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2);
#endif #endif
else sexp_raise("<: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i); _ARG2 = sexp_make_boolean(i);
top--; top--;
break; break;
@ -1590,7 +1593,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2);
#endif #endif
else sexp_raise("<=: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i); _ARG2 = sexp_make_boolean(i);
top--; top--;
break; break;
@ -1605,7 +1608,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2);
#endif #endif
else sexp_raise("=: not a number", sexp_list2(context, _ARG1, _ARG2)); else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i); _ARG2 = sexp_make_boolean(i);
top--; top--;
break; break;
@ -1615,12 +1618,12 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break; break;
case OP_FIX2FLO: case OP_FIX2FLO:
if (sexp_integerp(_ARG1)) if (sexp_integerp(_ARG1))
_ARG1 = sexp_integer_to_flonum(context, _ARG1); _ARG1 = sexp_integer_to_flonum(ctx, _ARG1);
else else
#if USE_FLONUMS #if USE_FLONUMS
if (! sexp_flonump(_ARG1)) if (! sexp_flonump(_ARG1))
#endif #endif
sexp_raise("exact->inexact: not a number", sexp_list1(context, _ARG1)); sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1));
break; break;
case OP_FLO2FIX: case OP_FLO2FIX:
#if USE_FLONUMS #if USE_FLONUMS
@ -1629,7 +1632,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
else else
#endif #endif
if (! sexp_integerp(_ARG1)) if (! sexp_integerp(_ARG1))
sexp_raise("inexact->exact: not a number", sexp_list1(context, _ARG1)); sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1));
break; break;
case OP_CHAR2INT: case OP_CHAR2INT:
_ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1));
@ -1675,7 +1678,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
_ARG1 = SEXP_VOID; _ARG1 = SEXP_VOID;
break; break;
case OP_READ: case OP_READ:
_ARG1 = sexp_read(context, _ARG1); _ARG1 = sexp_read(ctx, _ARG1);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_READ_CHAR: case OP_READ_CHAR:
@ -1700,11 +1703,12 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
case OP_DONE: case OP_DONE:
goto end_loop; goto end_loop;
default: default:
sexp_raise("unknown opcode", sexp_list1(context, sexp_make_integer(*(ip-1)))); sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1))));
} }
goto loop; goto loop;
end_loop: end_loop:
sexp_gc_release(ctx, self, s_self);
return _ARG1; return _ARG1;
} }
@ -1719,10 +1723,12 @@ static sexp sexp_exception_type_func (sexp ctx, sexp exn) {
static sexp sexp_open_input_file (sexp ctx, sexp path) { static sexp sexp_open_input_file (sexp ctx, sexp path) {
FILE *in; FILE *in;
if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); if (! sexp_stringp(path))
return sexp_type_exception(ctx, "not a string", path);
in = fopen(sexp_string_data(path), "r"); in = fopen(sexp_string_data(path), "r");
if (! in) if (! in)
return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); return
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path);
return sexp_make_input_port(ctx, in, sexp_string_data(path)); return sexp_make_input_port(ctx, in, sexp_string_data(path));
} }
@ -1732,7 +1738,8 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) {
return sexp_type_exception(ctx, "not a string", path); return sexp_type_exception(ctx, "not a string", path);
out = fopen(sexp_string_data(path), "w"); out = fopen(sexp_string_data(path), "w");
if (! out) if (! out)
return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); return
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path);
return sexp_make_input_port(ctx, out, sexp_string_data(path)); return sexp_make_input_port(ctx, out, sexp_string_data(path));
} }
@ -1781,8 +1788,6 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
sexp_warn_undefs(sexp_env_bindings(env), tmp, out); sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
#endif #endif
sexp_gc_release(ctx, ctx2, s_ctx2); sexp_gc_release(ctx, ctx2, s_ctx2);
sexp_gc_release(ctx, x, s_x);
sexp_gc_release(ctx, in, s_in);
return res; return res;
} }
@ -1898,6 +1903,7 @@ static struct sexp_struct core_forms[] = {
static sexp sexp_make_null_env (sexp ctx, sexp version) { static sexp sexp_make_null_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_lambda(e) = NULL;
sexp_env_parent(e) = NULL; sexp_env_parent(e) = NULL;
sexp_env_bindings(e) = SEXP_NULL; sexp_env_bindings(e) = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++)
@ -1938,14 +1944,13 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
sexp_make_output_port(ctx, stderr, NULL)); sexp_make_output_port(ctx, stderr, NULL));
env_define(ctx, e, the_interaction_env_symbol, e); env_define(ctx, e, the_interaction_env_symbol, e);
sexp_gc_release(ctx, e, s_e); sexp_gc_release(ctx, e, s_e);
sexp_gc_release(ctx, op, s_op);
return e; return e;
} }
/************************** eval interface ****************************/ /************************** eval interface ****************************/
sexp apply(sexp ctx, sexp proc, sexp args) { sexp apply (sexp ctx, sexp proc, sexp args) {
sexp *stack = sexp_context_stack(ctx), ls; sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
sexp_sint_t top = sexp_context_top(ctx), offset; sexp_sint_t top = sexp_context_top(ctx), offset;
offset = top + sexp_unbox_integer(sexp_length(ctx, args)); offset = top + sexp_unbox_integer(sexp_length(ctx, args));
for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
@ -1955,7 +1960,8 @@ sexp apply(sexp ctx, sexp proc, sexp args) {
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID);
stack[top++] = sexp_make_integer(0); stack[top++] = sexp_make_integer(0);
return vm(proc, ctx, stack, top); sexp_context_top(ctx) = top;
return vm(proc, ctx);
} }
sexp compile (sexp ctx, sexp x) { sexp compile (sexp ctx, sexp x) {
@ -1973,7 +1979,6 @@ sexp compile (sexp ctx, sexp x) {
finalize_bytecode(ctx2), finalize_bytecode(ctx2),
sexp_make_vector(ctx, 0, SEXP_VOID)); sexp_make_vector(ctx, 0, SEXP_VOID));
sexp_gc_release(ctx, ast, s_ast); sexp_gc_release(ctx, ast, s_ast);
sexp_gc_release(ctx, ctx2, s_ctx2);
return res; return res;
} }

299
gc.c
View file

@ -4,7 +4,7 @@
#include "sexp.h" #include "sexp.h"
#define SEXP_INITIAL_HEAP_SIZE 100000000 #define SEXP_INITIAL_HEAP_SIZE 50000
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
static char* sexp_heap; static char* sexp_heap;
@ -18,6 +18,8 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x);
case SEXP_VECTOR: case SEXP_VECTOR:
return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp));
case SEXP_STACK:
return sexp_sizeof(stack)+(sexp_stack_length(x)*sizeof(sexp));
case SEXP_FLONUM: return sexp_sizeof(flonum); case SEXP_FLONUM: return sexp_sizeof(flonum);
case SEXP_BIGNUM: return sexp_sizeof(bignum); case SEXP_BIGNUM: return sexp_sizeof(bignum);
case SEXP_IPORT: case SEXP_IPORT:
@ -37,27 +39,46 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
case SEXP_SEQ: return sexp_sizeof(seq); case SEXP_SEQ: return sexp_sizeof(seq);
case SEXP_LIT: return sexp_sizeof(lit); case SEXP_LIT: return sexp_sizeof(lit);
case SEXP_CONTEXT: return sexp_sizeof(context); case SEXP_CONTEXT: return sexp_sizeof(context);
default: return 0; default: return sexp_align(1, 4);
} }
} }
void sexp_mark (sexp x) { void sexp_mark (sexp x) {
sexp *data; sexp *data;
sexp_uint_t i; sexp_uint_t i;
struct sexp_gc_var_t *saves;
loop: loop:
if ((! sexp_pointerp(x)) || sexp_gc_mark(x)) if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) {
if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE))
fprintf(stderr, "--------------- outside heap: %p (%x) ------------------\n", x, sexp_pointer_tag(x));
return;
}
if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x))
return; return;
sexp_gc_mark(x) = 1; sexp_gc_mark(x) = 1;
fprintf(stderr, "----------------- marking %p (%x) --------------------\n",
x, sexp_pointer_tag(x));
switch (sexp_pointer_tag(x)) { switch (sexp_pointer_tag(x)) {
case SEXP_PAIR: case SEXP_PAIR:
sexp_mark(sexp_car(x)); sexp_mark(sexp_car(x));
x = sexp_cdr(x); x = sexp_cdr(x);
goto loop; goto loop;
case SEXP_STACK:
data = sexp_stack_data(x);
if (! sexp_stack_top(x)) break;
for (i=sexp_stack_top(x)-1; i>0; i--)
sexp_mark(data[i]);
x = data[0];
goto loop;
case SEXP_VECTOR: case SEXP_VECTOR:
data = sexp_vector_data(x); data = sexp_vector_data(x);
if (! sexp_vector_length(x)) break;
for (i=sexp_vector_length(x)-1; i>0; i--) for (i=sexp_vector_length(x)-1; i>0; i--)
sexp_mark(data[i]); sexp_mark(data[i]);
x = data[i]; x = data[0];
goto loop;
case SEXP_SYMBOL:
x = sexp_symbol_string(x);
goto loop; goto loop;
case SEXP_BYTECODE: case SEXP_BYTECODE:
x = sexp_bytecode_literals(x); x = sexp_bytecode_literals(x);
@ -119,71 +140,287 @@ void sexp_mark (sexp x) {
case SEXP_LIT: case SEXP_LIT:
x = sexp_lit_value(x); x = sexp_lit_value(x);
goto loop; goto loop;
case SEXP_CONTEXT:
sexp_mark(sexp_context_env(x));
sexp_mark(sexp_context_bc(x));
sexp_mark(sexp_context_fv(x));
sexp_mark(sexp_context_lambda(x));
sexp_mark(sexp_context_parent(x));
for (saves=sexp_context_saves(x); saves; saves=saves->next)
if (saves->var) sexp_mark(*(saves->var));
x = sexp_context_stack(x);
goto loop;
} }
} }
void simple_write (sexp obj, int depth, FILE *out) {
unsigned long len, c, res;
long i=0;
double f;
char *str=NULL;
if (! obj) {
fputs("#<null>", out);
} if (! sexp_pointerp(obj)) {
if (sexp_integerp(obj)) {
fprintf(out, "%ld", sexp_unbox_integer(obj));
} else if (sexp_charp(obj)) {
if (obj == sexp_make_character(' '))
fputs("#\\space", out);
else if (obj == sexp_make_character('\n'))
fputs("#\\newline", out);
else if (obj == sexp_make_character('\r'))
fputs("#\\return", out);
else if (obj == sexp_make_character('\t'))
fputs("#\\tab", out);
else if ((33 <= sexp_unbox_character(obj))
&& (sexp_unbox_character(obj) < 127))
fprintf(out, "#\\%c", sexp_unbox_character(obj));
else
fprintf(out, "#\\x%02d", sexp_unbox_character(obj));
} else if (sexp_symbolp(obj)) {
#if USE_HUFF_SYMS
if (((sexp_uint_t)obj&7)==7) {
c = ((sexp_uint_t)obj)>>3;
while (c) {
#include "sexp-unhuff.c"
putc(res, out);
}
}
#endif
} else {
switch ((sexp_uint_t) obj) {
case (sexp_uint_t) SEXP_NULL:
fputs("()", out); break;
case (sexp_uint_t) SEXP_TRUE:
fputs("#t", out); break;
case (sexp_uint_t) SEXP_FALSE:
fputs("#f", out); break;
case (sexp_uint_t) SEXP_EOF:
fputs("#<eof>", out); break;
case (sexp_uint_t) SEXP_UNDEF:
case (sexp_uint_t) SEXP_VOID:
fputs("#<undef>", out); break;
default:
fprintf(out, "#<invalid: %p>", obj);
}
}
} else if (depth <= 0) {
fprintf(out, "#<...>");
} else {
switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR:
putc('(', out);
simple_write(sexp_car(obj), depth-1, out);
if (sexp_pairp(sexp_cdr(obj))) {
fputs(" ...", out);
} else if (! sexp_nullp(sexp_cdr(obj))) {
fputs(" . ", out);
simple_write(sexp_cdr(obj), depth-1, out);
}
putc(')', out);
break;
case SEXP_VECTOR:
len = sexp_vector_length(obj);
if (len == 0) {
fputs("#()", out);
} else {
fprintf(out, "#(... %ld ...)", len);
}
break;
case SEXP_FLONUM:
f = sexp_flonum_value(obj);
fprintf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : "");
break;
case SEXP_PROCEDURE:
fputs("#<procedure: ", out);
simple_write(sexp_bytecode_name(sexp_procedure_code(obj)), depth-1, out);
putc('>', out);
break;
case SEXP_IPORT:
fputs("#<input-port>", out); break;
case SEXP_OPORT:
fputs("#<output-port>", out); break;
case SEXP_CORE:
fputs("#<core-form>", out); break;
case SEXP_OPCODE:
fputs("#<opcode>", out); break;
case SEXP_BYTECODE:
fputs("#<bytecode>", out); break;
case SEXP_ENV:
fprintf(out, "#<env %p>", obj); break;
case SEXP_EXCEPTION:
fputs("#<exception>", out); break;
case SEXP_MACRO:
fputs("#<macro>", out); break;
case SEXP_LAMBDA:
fputs("#<lambda ", out);
simple_write(sexp_lambda_params(obj), depth-1, out);
putc(' ', out);
simple_write(sexp_lambda_body(obj), depth-1, out);
putc('>', out);
break;
case SEXP_SEQ:
fputs("#<seq ", out);
simple_write(sexp_seq_ls(obj), depth-1, out);
putc('>', out);
break;
case SEXP_CND:
fputs("#<if ", out);
simple_write(sexp_cnd_test(obj), depth-1, out);
putc(' ', out);
simple_write(sexp_cnd_pass(obj), depth-1, out);
putc(' ', out);
simple_write(sexp_cnd_fail(obj), depth-1, out);
putc('>', out);
break;
case SEXP_REF:
fputs("#<ref: ", out);
simple_write(sexp_ref_name(obj), depth-1, out);
fprintf(out, " %p>", sexp_ref_loc(obj));
break;
case SEXP_SET:
fputs("#<set! ", out);
simple_write(sexp_set_var(obj), depth-1, out);
putc(' ', out);
simple_write(sexp_set_value(obj), depth-1, out);
putc('>', out);
break;
case SEXP_LIT:
fputs("#<lit ", out);
simple_write(sexp_lit_value(obj), depth-1, out);
putc('>', out);
break;
case SEXP_CONTEXT:
fputs("#<context>", out);
break;
case SEXP_SYNCLO:
fputs("#<sc ", out);
simple_write(sexp_synclo_expr(obj), depth-1, out);
putc('>', out);
break;
case SEXP_STRING:
putc('"', out);
i = sexp_string_length(obj);
str = sexp_string_data(obj);
for ( ; i>0; str++, i--) {
switch (str[0]) {
case '\\': fputs("\\\\", out); break;
case '"': fputs("\\\"", out); break;
case '\n': fputs("\\n", out); break;
case '\r': fputs("\\r", out); break;
case '\t': fputs("\\t", out); break;
default: putc(str[0], out);
}
}
putc('"', out);
break;
case SEXP_SYMBOL:
i = sexp_string_length(sexp_symbol_string(obj));
str = sexp_string_data(sexp_symbol_string(obj));
for ( ; i>0; str++, i--) {
if ((str[0] == '\\') || is_separator(str[0]))
putc('\\', out);
putc(str[0], out);
}
break;
default:
fprintf(out, "#<invalid type: %d>", sexp_pointer_tag(obj));
break;
}
}
}
void sexp_show_free_list (sexp ctx) {
sexp p=sexp_free_list;
fputs("free-list:", stderr);
while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) {
fprintf(stderr, " %p-%p", p, p+(sexp_uint_t)sexp_car(p));
p = sexp_cdr(p);
}
putc('\n', stderr);
}
sexp sexp_sweep (sexp ctx) { sexp sexp_sweep (sexp ctx) {
sexp_uint_t freed=0, size; sexp_uint_t freed=0, size;
sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4));
sexp f1=sexp_free_list, f2;
/* scan over the whole heap */
while ((char*)p<sexp_heap_end) { while ((char*)p<sexp_heap_end) {
for (f2=sexp_cdr(f1); sexp_pairp(f2) && (f2 < p); f1=f2, f2=sexp_cdr(f2)) /* find the preceding and succeeding free list pointers */
for (f2=sexp_cdr(f1); f2 && sexp_pairp(f2) && (f2 < p); f1=f2, f2=sexp_cdr(f2))
; ;
size = sexp_allocated_bytes(p); fprintf(stderr, "p: %p f1: %p f2: %p\n", p, f1, f2);
size = sexp_align(sexp_allocated_bytes(p), 4);
if (! sexp_gc_mark(p)) { if (! sexp_gc_mark(p)) {
fprintf(stderr, "freeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p));
simple_write(p, 1, stderr);
fprintf(stderr, " -\n");
freed += size; freed += size;
sexp_pointer_tag(p) = SEXP_PAIR;
sexp_car(p) = (sexp)size; sexp_car(p) = (sexp)size;
sexp_cdr(p) = f2; sexp_cdr(p) = f2;
f1 = f2; sexp_cdr(f1) = p;
/* f1 = f2; */
} else { } else {
fprintf(stderr, "saving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p));
simple_write(p, 1, stderr);
fprintf(stderr, " +\n");
sexp_gc_mark(p) = 0; sexp_gc_mark(p) = 0;
} }
p += size; p = (sexp) (((char*)p)+size);
} }
fprintf(stderr, "**************** freed %ld bytes ****************\n", freed);
return sexp_make_integer(freed); return sexp_make_integer(freed);
} }
extern sexp continuation_resumer, final_resumer;
sexp sexp_gc (sexp ctx) { sexp sexp_gc (sexp ctx) {
int i; int i;
struct sexp_gc_var_t *saves;
sexp *stack = sexp_context_stack(ctx);
fprintf(stderr, "************* garbage collecting *************\n"); fprintf(stderr, "************* garbage collecting *************\n");
sexp_show_free_list(ctx);
sexp_mark(continuation_resumer);
sexp_mark(final_resumer);
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++) for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
sexp_mark(sexp_symbol_table[i]); sexp_mark(sexp_symbol_table[i]);
for (i=0; i<sexp_context_top(ctx); i++) sexp_mark(ctx);
sexp_mark(stack[i]);
for ( ; ctx; ctx=sexp_context_parent(ctx)) {
sexp_gc_mark(ctx) = 1;
if (sexp_context_bc(ctx)) sexp_mark(sexp_context_bc(ctx));
sexp_mark(sexp_context_env(ctx));
for (saves=sexp_context_saves(ctx); saves; saves=saves->next)
if (saves->var) sexp_mark(*(saves->var));
}
return sexp_sweep(ctx); return sexp_sweep(ctx);
} }
void *sexp_alloc (sexp ctx, size_t size) { void *sexp_alloc (sexp ctx, size_t size) {
int tries = 0;
sexp ls1, ls2, ls3; sexp ls1, ls2, ls3;
size = sexp_align(size, 3); size = sexp_align(size, 4);
try_alloc: try_alloc:
ls1=sexp_free_list; ls1 = sexp_free_list;
for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) ls2 = sexp_cdr(ls1);
for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ) {
if ((sexp_uint_t)sexp_car(ls2) >= size) { if ((sexp_uint_t)sexp_car(ls2) >= size) {
if ((sexp_uint_t)sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
ls3 = (sexp) (((char*)ls2)+size); ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */
sexp_pointer_tag(ls3) = SEXP_PAIR; sexp_pointer_tag(ls3) = SEXP_PAIR;
sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size);
sexp_cdr(ls3) = sexp_cdr(ls2); sexp_cdr(ls3) = sexp_cdr(ls2);
sexp_cdr(ls1) = ls3; sexp_cdr(ls1) = ls3;
} else { } else { /* take the whole chunk */
sexp_cdr(ls1) = sexp_cdr(ls2); sexp_cdr(ls1) = sexp_cdr(ls2);
} }
bzero((void*)ls2, size); bzero((void*)ls2, size);
return ls2; return ls2;
} }
if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { ls1=ls2;
ls2=sexp_cdr(ls2);
}
if ((! tries) && (sexp_unbox_integer(sexp_gc(ctx)) >= size)) {
tries++;
goto try_alloc; goto try_alloc;
} else { } else {
fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); fprintf(stderr,
"chibi: out of memory trying to allocate %ld bytes, aborting\n",
size);
exit(70); exit(70);
} }
} }
@ -193,12 +430,14 @@ void sexp_gc_init () {
sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE);
sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE;
sexp_free_list = (sexp)sexp_heap; sexp_free_list = (sexp)sexp_heap;
next = (sexp) (sexp_heap + sexp_sizeof(pair)); next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4));
sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; sexp_pointer_tag(sexp_free_list) = SEXP_PAIR;
sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */
sexp_cdr(sexp_free_list) = next; sexp_cdr(sexp_free_list) = next;
sexp_pointer_tag(next) = SEXP_PAIR; sexp_pointer_tag(next) = SEXP_PAIR;
sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE-sexp_sizeof(pair)); sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE
- sexp_align(sexp_sizeof(pair), 4));
sexp_cdr(next) = SEXP_NULL; sexp_cdr(next) = SEXP_NULL;
fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next);
} }

24
sexp.c
View file

@ -117,10 +117,17 @@ sexp sexp_type_exception (sexp ctx, char *message, sexp obj) {
} }
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
return sexp_make_exception(ctx, sexp_intern(ctx, "range"), sexp_gc_var(ctx, res, s_res);
sexp_c_string(ctx, "bad index range", -1), sexp_gc_var(ctx, msg, s_msg);
sexp_list3(ctx, obj, start, end), sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, msg, s_msg);
msg = sexp_c_string(ctx, "bad index range", -1);
res = sexp_list2(ctx, start, end);
res = sexp_cons(ctx, obj, res);
res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res,
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
sexp_gc_release(ctx, res, s_res);
return res;
} }
sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
@ -193,6 +200,15 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) {
return pair; return pair;
} }
sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
sexp_gc_var(ctx, res, s_res);
sexp_gc_preserve(ctx, res, s_res);
res = sexp_cons(ctx, b, SEXP_NULL);
res = sexp_cons(ctx, a, res);
sexp_gc_release(ctx, res, s_res);
return res;
}
sexp sexp_listp (sexp ctx, sexp hare) { sexp sexp_listp (sexp ctx, sexp hare) {
sexp turtle; sexp turtle;
if (! sexp_pairp(hare)) if (! sexp_pairp(hare))
@ -996,7 +1012,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
in); in);
} }
break; break;
/* case '=': */
/* case '0': case '1': case '2': case '3': case '4': */ /* case '0': case '1': case '2': case '3': case '4': */
/* case '5': case '6': case '7': case '8': case '9': */ /* case '5': case '6': case '7': case '8': case '9': */
case ';': case ';':
@ -1097,7 +1112,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
} }
sexp_gc_release(ctx, res, s_res); sexp_gc_release(ctx, res, s_res);
sexp_gc_release(ctx, tmp, s_tmp);
return res; return res;
} }

47
sexp.h
View file

@ -78,6 +78,7 @@ enum sexp_types {
SEXP_SET, SEXP_SET,
SEXP_SEQ, SEXP_SEQ,
SEXP_LIT, SEXP_LIT,
SEXP_STACK,
SEXP_CONTEXT, SEXP_CONTEXT,
}; };
@ -178,13 +179,29 @@ struct sexp_struct {
} lit; } lit;
/* compiler state */ /* compiler state */
struct { struct {
sexp bc, lambda, *stack, env, fv, parent; sexp_uint_t length, top;
sexp data[];
} stack;
struct {
sexp bc, lambda, stack, env, fv, parent;
struct sexp_gc_var_t *saves; struct sexp_gc_var_t *saves;
sexp_uint_t pos, top, depth, tailp, tracep; sexp_uint_t pos, depth, tailp, tracep;
} context; } context;
} value; } value;
}; };
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+ SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
#if USE_BOEHM #if USE_BOEHM
#define sexp_gc_var(ctx, x, y) sexp x; #define sexp_gc_var(ctx, x, y) sexp x;
@ -202,7 +219,7 @@ struct sexp_struct {
#define sexp_gc_var(ctx, x, y) \ #define sexp_gc_var(ctx, x, y) \
sexp x = SEXP_FALSE; \ sexp x = SEXP_FALSE; \
struct sexp_gc_var_t y; struct sexp_gc_var_t y = {0, 0};
#define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \ #define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \
(y).next = sexp_context_saves(ctx), \ (y).next = sexp_context_saves(ctx), \
@ -248,18 +265,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag)
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+ SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
/***************************** predicates *****************************/ /***************************** predicates *****************************/
#define sexp_nullp(x) ((x) == SEXP_NULL) #define sexp_nullp(x) ((x) == SEXP_NULL)
@ -295,6 +300,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) #define sexp_setp(x) (sexp_check_tag(x, SEXP_SET))
#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) #define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ))
#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) #define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT))
#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT))
#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x))
#define sexp_idp(x) \ #define sexp_idp(x) \
@ -414,19 +420,24 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_lit_value(x) ((x)->value.lit.value) #define sexp_lit_value(x) ((x)->value.lit.value)
#define sexp_stack_length(x) ((x)->value.stack.length)
#define sexp_stack_top(x) ((x)->value.stack.top)
#define sexp_stack_data(x) ((x)->value.stack.data)
#define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_env(x) ((x)->value.context.env)
#define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_stack(x) ((x)->value.context.stack)
#define sexp_context_depth(x) ((x)->value.context.depth) #define sexp_context_depth(x) ((x)->value.context.depth)
#define sexp_context_bc(x) ((x)->value.context.bc) #define sexp_context_bc(x) ((x)->value.context.bc)
#define sexp_context_fv(x) ((x)->value.context.fv) #define sexp_context_fv(x) ((x)->value.context.fv)
#define sexp_context_pos(x) ((x)->value.context.pos) #define sexp_context_pos(x) ((x)->value.context.pos)
#define sexp_context_top(x) ((x)->value.context.top)
#define sexp_context_lambda(x) ((x)->value.context.lambda) #define sexp_context_lambda(x) ((x)->value.context.lambda)
#define sexp_context_parent(x) ((x)->value.context.parent) #define sexp_context_parent(x) ((x)->value.context.parent)
#define sexp_context_saves(x) ((x)->value.context.saves) #define sexp_context_saves(x) ((x)->value.context.saves)
#define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tailp(x) ((x)->value.context.tailp)
#define sexp_context_tracep(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp)
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
/****************************** arithmetic ****************************/ /****************************** arithmetic ****************************/
#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
@ -444,9 +455,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
/****************************** utilities *****************************/ /****************************** utilities *****************************/
#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) #define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL)
#define sexp_list2(x,a,b) sexp_cons((x), (a), sexp_cons((x), (b), SEXP_NULL))
#define sexp_list3(x,a,b,c) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), SEXP_NULL)))
#define sexp_list4(x,a,b,c,d) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), sexp_cons((x), (d), SEXP_NULL))))
#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls)))
#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) #define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x)))
@ -481,6 +489,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
sexp sexp_cons(sexp ctx, sexp head, sexp tail); sexp sexp_cons(sexp ctx, sexp head, sexp tail);
sexp sexp_list2(sexp ctx, sexp a, sexp b);
sexp sexp_equalp (sexp ctx, sexp a, sexp b); sexp sexp_equalp (sexp ctx, sexp a, sexp b);
sexp sexp_listp(sexp ctx, sexp obj); sexp sexp_listp(sexp ctx, sexp obj);
sexp sexp_reverse(sexp ctx, sexp ls); sexp sexp_reverse(sexp ctx, sexp ls);