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

while still working towards the precise gc, reordering the

Browse source 
context argument to all functions
This commit is contained in:
Alex Shinn 2009-05-08 23:27:04 +09:00
parent 28d5775bbe
commit a85d80038c
5 changed files with 533 additions and 451 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

812
eval.c
View file

File diff suppressed because it is too large Load diff

2
gc.c
View file

@ -155,7 +155,7 @@ sexp sexp_gc (sexp ctx) {
sexp_gc_mark(ctx) = 1; sexp_gc_mark(ctx) = 1;
if (sexp_context_bc(ctx)) sexp_mark(sexp_context_bc(ctx)); if (sexp_context_bc(ctx)) sexp_mark(sexp_context_bc(ctx));
sexp_mark(sexp_context_env(ctx)); sexp_mark(sexp_context_env(ctx));
for (saves=&(sexp_context_saves(ctx)); saves; saves=saves->next) for (saves=sexp_context_saves(ctx); saves; saves=saves->next)
if (saves->var) sexp_mark(*(saves->var)); if (saves->var) sexp_mark(*(saves->var));
} }
return sexp_sweep(ctx); return sexp_sweep(ctx);

68
main.c
View file

@ -1,24 +1,24 @@
#include "eval.c" #include "eval.c"
void repl (sexp context) { void repl (sexp ctx) {
sexp obj, tmp, res, env, in, out, err; sexp obj, tmp, res, env, in, out, err;
env = sexp_context_env(context); env = sexp_context_env(ctx);
sexp_context_tracep(context) = 1; sexp_context_tracep(ctx) = 1;
in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE);
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
while (1) { while (1) {
sexp_write_string("> ", out); sexp_write_string("> ", out);
sexp_flush(out); sexp_flush(out);
obj = sexp_read(context, in); obj = sexp_read(ctx, in);
if (obj == SEXP_EOF) if (obj == SEXP_EOF)
break; break;
if (sexp_exceptionp(obj)) { if (sexp_exceptionp(obj)) {
sexp_print_exception(context, obj, err); sexp_print_exception(ctx, obj, err);
} else { } else {
tmp = sexp_env_bindings(env); tmp = sexp_env_bindings(env);
res = eval_in_context(obj, context); res = eval_in_context(ctx, obj);
#if USE_WARN_UNDEFS #if USE_WARN_UNDEFS
sexp_warn_undefs(sexp_env_bindings(env), tmp, err); sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
#endif #endif
@ -31,33 +31,33 @@ void repl (sexp context) {
} }
void run_main (int argc, char **argv) { void run_main (int argc, char **argv) {
sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; sexp env, out=NULL, res, ctx, perr_cell, err_cell, err_handler;
sexp_uint_t i, quit=0, init_loaded=0; sexp_uint_t i, quit=0, init_loaded=0;
context = sexp_make_context(NULL, NULL, NULL); ctx = sexp_make_context(NULL, NULL, NULL);
env = sexp_make_standard_env(context, sexp_make_integer(5)); env = sexp_make_standard_env(ctx, sexp_make_integer(5));
env_define(context, env, the_interaction_env_symbol, env); env_define(ctx, env, the_interaction_env_symbol, env);
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err_cell = env_cell(env, the_cur_err_symbol); err_cell = env_cell(env, the_cur_err_symbol);
perr_cell = env_cell(env, sexp_intern(context, "print-exception")); perr_cell = env_cell(env, sexp_intern(ctx, "print-exception"));
sexp_context_env(context) = env; sexp_context_env(ctx) = env;
sexp_context_tailp(context) = 0; sexp_context_tailp(ctx) = 0;
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
emit(OP_GLOBAL_KNOWN_REF, context); emit(ctx, OP_GLOBAL_KNOWN_REF);
emit_word((sexp_uint_t)err_cell, context); emit_word(ctx, (sexp_uint_t)err_cell);
emit(OP_LOCAL_REF, context); emit(ctx, OP_LOCAL_REF);
emit_word(0, context); emit_word(ctx, 0);
emit(OP_FCALL2, context); emit(ctx, OP_FCALL2);
emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context); emit_word(ctx, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)));
} }
emit_push(SEXP_VOID, context); emit_push(ctx, SEXP_VOID);
emit(OP_DONE, context); emit(ctx, OP_DONE);
err_handler = sexp_make_procedure(context, err_handler = sexp_make_procedure(ctx,
sexp_make_integer(0), sexp_make_integer(0),
sexp_make_integer(0), sexp_make_integer(0),
finalize_bytecode(context), finalize_bytecode(ctx),
sexp_make_vector(context, 0, SEXP_VOID)); sexp_make_vector(ctx, 0, SEXP_VOID));
env_define(context, env, the_err_handler_symbol, err_handler); env_define(ctx, env, the_err_handler_symbol, err_handler);
/* parse options */ /* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) { for (i=1; i < argc && argv[i][0] == '-'; i++) {
@ -66,12 +66,12 @@ void run_main (int argc, char **argv) {
case 'e': case 'e':
case 'p': case 'p':
if (! init_loaded++) if (! init_loaded++)
sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env);
res = sexp_read_from_string(context, argv[i+1]); res = sexp_read_from_string(ctx, argv[i+1]);
if (! sexp_exceptionp(res)) if (! sexp_exceptionp(res))
res = eval_in_context(res, context); res = eval_in_context(ctx, res);
if (sexp_exceptionp(res)) { if (sexp_exceptionp(res)) {
sexp_print_exception(context, res, out); sexp_print_exception(ctx, res, out);
} else if (argv[i][1] == 'p') { } else if (argv[i][1] == 'p') {
sexp_write(res, out); sexp_write(res, out);
sexp_write_char('\n', out); sexp_write_char('\n', out);
@ -82,8 +82,8 @@ void run_main (int argc, char **argv) {
#endif #endif
case 'l': case 'l':
if (! init_loaded++) if (! init_loaded++)
sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env);
sexp_load(context, sexp_c_string(context, argv[++i], -1), env); sexp_load(ctx, sexp_c_string(ctx, argv[++i], -1), env);
break; break;
case 'q': case 'q':
init_loaded = 1; init_loaded = 1;
@ -95,12 +95,12 @@ void run_main (int argc, char **argv) {
if (! quit) { if (! quit) {
if (! init_loaded) if (! init_loaded)
sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env);
if (i < argc) if (i < argc)
for ( ; i < argc; i++) for ( ; i < argc; i++)
sexp_load(context, sexp_c_string(context, argv[i], -1), env); sexp_load(ctx, sexp_c_string(ctx, argv[i], -1), env);
else else
repl(context); repl(ctx);
} }
} }

60
sexp.c
View file

@ -237,7 +237,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) {
if (ls == SEXP_NULL) { if (ls == SEXP_NULL) {
return ls; return ls;
} else if (! sexp_pairp(ls)) { } else if (! sexp_pairp(ls)) {
return SEXP_ERROR; return SEXP_NULL; /* XXXX return an exception */
} else { } else {
b = ls; b = ls;
a = sexp_cdr(ls); a = sexp_cdr(ls);
@ -748,8 +748,6 @@ void sexp_write (sexp obj, sexp out) {
case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_UNDEF:
case (sexp_uint_t) SEXP_VOID: case (sexp_uint_t) SEXP_VOID:
sexp_write_string("#<undef>", out); break; sexp_write_string("#<undef>", out); break;
case (sexp_uint_t) SEXP_ERROR:
sexp_write_string("#<error>", out); break;
default: default:
sexp_printf(out, "#<invalid: %p>", obj); sexp_printf(out, "#<invalid: %p>", obj);
} }
@ -878,9 +876,13 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) {
} }
sexp sexp_read_raw (sexp ctx, sexp in) { sexp sexp_read_raw (sexp ctx, sexp in) {
sexp res, tmp, tmp2;
char *str; char *str;
int c1, c2; int c1, c2;
sexp tmp2;
sexp_gc_var(ctx, res, s_res);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, res, s_res);
sexp_gc_preserve(ctx, tmp, s_tmp);
scan_loop: scan_loop:
switch (c1 = sexp_read_char(in)) { switch (c1 = sexp_read_char(in)) {
@ -924,34 +926,41 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
case '(': case '(':
res = SEXP_NULL; res = SEXP_NULL;
tmp = sexp_read_raw(ctx, in); tmp = sexp_read_raw(ctx, in);
while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) {
if (tmp == SEXP_RAWDOT) { res = sexp_cons(ctx, tmp, res);
tmp = sexp_read_raw(ctx, in);
if (sexp_exceptionp(tmp)) {
res = tmp;
break;
}
}
if (! sexp_exceptionp(res)) {
if (tmp == SEXP_RAWDOT) { /* dotted list */
if (res == SEXP_NULL) { if (res == SEXP_NULL) {
return sexp_read_error(ctx, "dot before any elements in list", res = sexp_read_error(ctx, "dot before any elements in list",
SEXP_NULL, in); SEXP_NULL, in);
} else { } else {
tmp = sexp_read_raw(ctx, in); tmp = sexp_read_raw(ctx, in);
if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { if (sexp_exceptionp(tmp)) {
sexp_deep_free(ctx, res); res = tmp;
return sexp_read_error(ctx, "multiple tokens in dotted tail", } else if (tmp == SEXP_CLOSE) {
SEXP_NULL, in); res = sexp_read_error(ctx, "no final element in list after dot",
SEXP_NULL, in);
} else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) {
res = sexp_read_error(ctx, "multiple tokens in dotted tail",
SEXP_NULL, in);
} else { } else {
tmp2 = res; tmp2 = res;
res = sexp_nreverse(ctx, res); res = sexp_nreverse(ctx, res);
sexp_cdr(tmp2) = tmp; sexp_cdr(tmp2) = tmp;
return res;
} }
} }
} else if (tmp == SEXP_CLOSE) {
res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
} else { } else {
res = sexp_cons(ctx, tmp, res); res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in);
tmp = sexp_read_raw(ctx, in);
} }
} }
if (tmp != SEXP_CLOSE) {
sexp_deep_free(ctx, res);
return sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in);
}
res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
break; break;
case '#': case '#':
switch (c1=sexp_read_char(in)) { switch (c1=sexp_read_char(in)) {
@ -987,8 +996,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
in); in);
} }
break; break;
/* case '=': */
/* case '0': case '1': case '2': case '3': case '4': */
/* case '5': case '6': case '7': case '8': case '9': */
case ';': case ';':
sexp_read_raw(ctx, in); sexp_read_raw(ctx, in); /* discard */
goto scan_loop; goto scan_loop;
case '\\': case '\\':
c1 = sexp_read_char(in); c1 = sexp_read_char(in);
@ -1061,8 +1073,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
if (c2 == '.' || isdigit(c2)) { if (c2 == '.' || isdigit(c2)) {
sexp_push_char(c2, in); sexp_push_char(c2, in);
res = sexp_read_number(ctx, in, 10); res = sexp_read_number(ctx, in, 10);
if (sexp_exceptionp(res)) return res; if ((c1 == '-') && ! sexp_exceptionp(res)) {
if (c1 == '-') {
#ifdef USE_FLONUMS #ifdef USE_FLONUMS
if (sexp_flonump(res)) if (sexp_flonump(res))
sexp_flonum_value(res) = -1 * sexp_flonum_value(res); sexp_flonum_value(res) = -1 * sexp_flonum_value(res);
@ -1084,6 +1095,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
res = sexp_read_symbol(ctx, in, c1, 1); res = sexp_read_symbol(ctx, in, c1, 1);
break; break;
} }
sexp_gc_release(ctx, res, s_res);
sexp_gc_release(ctx, tmp, s_tmp);
return res; return res;
} }

42
sexp.h
View file

@ -179,7 +179,7 @@ struct sexp_struct {
/* compiler state */ /* compiler state */
struct { struct {
sexp bc, lambda, *stack, env, fv, parent; 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, top, depth, tailp, tracep;
} context; } context;
} value; } value;
@ -188,6 +188,7 @@ struct sexp_struct {
#if USE_BOEHM #if USE_BOEHM
#define sexp_gc_var(ctx, x, y) sexp x; #define sexp_gc_var(ctx, x, y) sexp x;
#define sexp_gc_preserve(ctx, x, y)
#define sexp_gc_release(ctx, x, y) #define sexp_gc_release(ctx, x, y)
#include "gc/include/gc.h" #include "gc/include/gc.h"
@ -200,11 +201,28 @@ struct sexp_struct {
#else #else
#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 = {&x, &(sexp_context_saves(cxt))}; \ struct sexp_gc_var_t y;
sexp_context_saves(cxt) = &y;
#define sexp_gc_release(ctx, x, y) (sexp_context_saves(cxt) = y.next) #define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \
(y).next = sexp_context_saves(ctx), \
sexp_context_saves(ctx) = &(y))
#define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next)
#define sexp_with_gc_var1(ctx, x, body) \
sexp_gc_var(ctx, x, _sexp_gcv1); \
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
do {body} while (0); \
sexp_gc_release(ctx, x, _sexp_gcv1);
#define sexp_with_gc_var2(ctx, x, y, body) \
sexp_gc_var(ctx, x, _sexp_gcv1); \
sexp_gc_var(ctx, y, _sexp_gcv2); \
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
sexp_gc_preserve(ctx, y, _sexp_gcv2); \
do {body} while (0); \
sexp_gc_release(ctx, x, _sexp_gcv1); \
sexp_gc_release(ctx, y, _sexp_gcv2);
#if USE_MALLOC #if USE_MALLOC
#define sexp_alloc(ctx, size) malloc(size) #define sexp_alloc(ctx, size) malloc(size)
@ -237,11 +255,10 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) #define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) #define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) #define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) #define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* internal use */ #define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(7) /* internal use */ #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(8) /* internal use */
/***************************** predicates *****************************/ /***************************** predicates *****************************/
@ -280,6 +297,9 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) #define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT))
#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x))
#define sexp_idp(x) \
(sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
/***************************** constructors ****************************/ /***************************** constructors ****************************/
#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
@ -446,7 +466,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) #define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x)))
#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) #define sexp_cddar(x) (sexp_cdr(sexp_cdar(x)))
#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) #define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x)))
#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) #define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
/***************************** general API ****************************/ /***************************** general API ****************************/