mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-07 13:16:36 +02:00
while still working towards the precise gc, reordering the
context argument to all functions
This commit is contained in:
Alex Shinn
parent
28d5775bbe
commit
a85d80038c
5 changed files with 533 additions and 451 deletions
2
gc.c
2
gc.c
|
|
@ -155,7 +155,7 @@ sexp sexp_gc (sexp 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)
|
||||
for (saves=sexp_context_saves(ctx); saves; saves=saves->next)
|
||||
if (saves->var) sexp_mark(*(saves->var));
|
||||
}
|
||||
return sexp_sweep(ctx);
|
||||
|
|
|
|||
68
main.c
68
main.c
|
|
@ -1,24 +1,24 @@
|
|||
|
||||
#include "eval.c"
|
||||
|
||||
void repl (sexp context) {
|
||||
void repl (sexp ctx) {
|
||||
sexp obj, tmp, res, env, in, out, err;
|
||||
env = sexp_context_env(context);
|
||||
sexp_context_tracep(context) = 1;
|
||||
env = sexp_context_env(ctx);
|
||||
sexp_context_tracep(ctx) = 1;
|
||||
in = env_global_ref(env, the_cur_in_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);
|
||||
while (1) {
|
||||
sexp_write_string("> ", out);
|
||||
sexp_flush(out);
|
||||
obj = sexp_read(context, in);
|
||||
obj = sexp_read(ctx, in);
|
||||
if (obj == SEXP_EOF)
|
||||
break;
|
||||
if (sexp_exceptionp(obj)) {
|
||||
sexp_print_exception(context, obj, err);
|
||||
sexp_print_exception(ctx, obj, err);
|
||||
} else {
|
||||
tmp = sexp_env_bindings(env);
|
||||
res = eval_in_context(obj, context);
|
||||
res = eval_in_context(ctx, obj);
|
||||
#if USE_WARN_UNDEFS
|
||||
sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
|
||||
#endif
|
||||
|
|
@ -31,33 +31,33 @@ void repl (sexp context) {
|
|||
}
|
||||
|
||||
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;
|
||||
|
||||
context = sexp_make_context(NULL, NULL, NULL);
|
||||
env = sexp_make_standard_env(context, sexp_make_integer(5));
|
||||
env_define(context, env, the_interaction_env_symbol, env);
|
||||
ctx = sexp_make_context(NULL, NULL, NULL);
|
||||
env = sexp_make_standard_env(ctx, sexp_make_integer(5));
|
||||
env_define(ctx, env, the_interaction_env_symbol, env);
|
||||
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
|
||||
err_cell = env_cell(env, the_cur_err_symbol);
|
||||
perr_cell = env_cell(env, sexp_intern(context, "print-exception"));
|
||||
sexp_context_env(context) = env;
|
||||
sexp_context_tailp(context) = 0;
|
||||
perr_cell = env_cell(env, sexp_intern(ctx, "print-exception"));
|
||||
sexp_context_env(ctx) = env;
|
||||
sexp_context_tailp(ctx) = 0;
|
||||
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
|
||||
emit(OP_GLOBAL_KNOWN_REF, context);
|
||||
emit_word((sexp_uint_t)err_cell, context);
|
||||
emit(OP_LOCAL_REF, context);
|
||||
emit_word(0, context);
|
||||
emit(OP_FCALL2, context);
|
||||
emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context);
|
||||
emit(ctx, OP_GLOBAL_KNOWN_REF);
|
||||
emit_word(ctx, (sexp_uint_t)err_cell);
|
||||
emit(ctx, OP_LOCAL_REF);
|
||||
emit_word(ctx, 0);
|
||||
emit(ctx, OP_FCALL2);
|
||||
emit_word(ctx, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)));
|
||||
}
|
||||
emit_push(SEXP_VOID, context);
|
||||
emit(OP_DONE, context);
|
||||
err_handler = sexp_make_procedure(context,
|
||||
emit_push(ctx, SEXP_VOID);
|
||||
emit(ctx, OP_DONE);
|
||||
err_handler = sexp_make_procedure(ctx,
|
||||
sexp_make_integer(0),
|
||||
sexp_make_integer(0),
|
||||
finalize_bytecode(context),
|
||||
sexp_make_vector(context, 0, SEXP_VOID));
|
||||
env_define(context, env, the_err_handler_symbol, err_handler);
|
||||
finalize_bytecode(ctx),
|
||||
sexp_make_vector(ctx, 0, SEXP_VOID));
|
||||
env_define(ctx, env, the_err_handler_symbol, err_handler);
|
||||
|
||||
/* parse options */
|
||||
for (i=1; i < argc && argv[i][0] == '-'; i++) {
|
||||
|
|
@ -66,12 +66,12 @@ void run_main (int argc, char **argv) {
|
|||
case 'e':
|
||||
case 'p':
|
||||
if (! init_loaded++)
|
||||
sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env);
|
||||
res = sexp_read_from_string(context, argv[i+1]);
|
||||
sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env);
|
||||
res = sexp_read_from_string(ctx, argv[i+1]);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = eval_in_context(res, context);
|
||||
res = eval_in_context(ctx, res);
|
||||
if (sexp_exceptionp(res)) {
|
||||
sexp_print_exception(context, res, out);
|
||||
sexp_print_exception(ctx, res, out);
|
||||
} else if (argv[i][1] == 'p') {
|
||||
sexp_write(res, out);
|
||||
sexp_write_char('\n', out);
|
||||
|
|
@ -82,8 +82,8 @@ void run_main (int argc, char **argv) {
|
|||
#endif
|
||||
case 'l':
|
||||
if (! init_loaded++)
|
||||
sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env);
|
||||
sexp_load(context, sexp_c_string(context, argv[++i], -1), env);
|
||||
sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env);
|
||||
sexp_load(ctx, sexp_c_string(ctx, argv[++i], -1), env);
|
||||
break;
|
||||
case 'q':
|
||||
init_loaded = 1;
|
||||
|
|
@ -95,12 +95,12 @@ void run_main (int argc, char **argv) {
|
|||
|
||||
if (! quit) {
|
||||
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)
|
||||
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
|
||||
repl(context);
|
||||
repl(ctx);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
60
sexp.c
60
sexp.c
|
|
@ -237,7 +237,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) {
|
|||
if (ls == SEXP_NULL) {
|
||||
return ls;
|
||||
} else if (! sexp_pairp(ls)) {
|
||||
return SEXP_ERROR;
|
||||
return SEXP_NULL; /* XXXX return an exception */
|
||||
} else {
|
||||
b = 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_VOID:
|
||||
sexp_write_string("#<undef>", out); break;
|
||||
case (sexp_uint_t) SEXP_ERROR:
|
||||
sexp_write_string("#<error>", out); break;
|
||||
default:
|
||||
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 res, tmp, tmp2;
|
||||
char *str;
|
||||
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:
|
||||
switch (c1 = sexp_read_char(in)) {
|
||||
|
|
@ -924,34 +926,41 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
case '(':
|
||||
res = SEXP_NULL;
|
||||
tmp = sexp_read_raw(ctx, in);
|
||||
while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) {
|
||||
if (tmp == SEXP_RAWDOT) {
|
||||
while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (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) {
|
||||
return sexp_read_error(ctx, "dot before any elements in list",
|
||||
SEXP_NULL, in);
|
||||
res = sexp_read_error(ctx, "dot before any elements in list",
|
||||
SEXP_NULL, in);
|
||||
} else {
|
||||
tmp = sexp_read_raw(ctx, in);
|
||||
if (sexp_read_raw(ctx, in) != SEXP_CLOSE) {
|
||||
sexp_deep_free(ctx, res);
|
||||
return sexp_read_error(ctx, "multiple tokens in dotted tail",
|
||||
SEXP_NULL, in);
|
||||
if (sexp_exceptionp(tmp)) {
|
||||
res = tmp;
|
||||
} else if (tmp == SEXP_CLOSE) {
|
||||
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 {
|
||||
tmp2 = res;
|
||||
res = sexp_nreverse(ctx, res);
|
||||
sexp_cdr(tmp2) = tmp;
|
||||
return res;
|
||||
}
|
||||
}
|
||||
} else if (tmp == SEXP_CLOSE) {
|
||||
res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
|
||||
} else {
|
||||
res = sexp_cons(ctx, tmp, res);
|
||||
tmp = sexp_read_raw(ctx, in);
|
||||
res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, 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;
|
||||
case '#':
|
||||
switch (c1=sexp_read_char(in)) {
|
||||
|
|
@ -987,8 +996,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
in);
|
||||
}
|
||||
break;
|
||||
/* case '=': */
|
||||
/* case '0': case '1': case '2': case '3': case '4': */
|
||||
/* case '5': case '6': case '7': case '8': case '9': */
|
||||
case ';':
|
||||
sexp_read_raw(ctx, in);
|
||||
sexp_read_raw(ctx, in); /* discard */
|
||||
goto scan_loop;
|
||||
case '\\':
|
||||
c1 = sexp_read_char(in);
|
||||
|
|
@ -1061,8 +1073,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
if (c2 == '.' || isdigit(c2)) {
|
||||
sexp_push_char(c2, in);
|
||||
res = sexp_read_number(ctx, in, 10);
|
||||
if (sexp_exceptionp(res)) return res;
|
||||
if (c1 == '-') {
|
||||
if ((c1 == '-') && ! sexp_exceptionp(res)) {
|
||||
#ifdef USE_FLONUMS
|
||||
if (sexp_flonump(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);
|
||||
break;
|
||||
}
|
||||
|
||||
sexp_gc_release(ctx, res, s_res);
|
||||
sexp_gc_release(ctx, tmp, s_tmp);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
|
|||
42
sexp.h
42
sexp.h
|
|
@ -179,7 +179,7 @@ struct sexp_struct {
|
|||
/* compiler state */
|
||||
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;
|
||||
} context;
|
||||
} value;
|
||||
|
|
@ -188,6 +188,7 @@ struct sexp_struct {
|
|||
#if USE_BOEHM
|
||||
|
||||
#define sexp_gc_var(ctx, x, y) sexp x;
|
||||
#define sexp_gc_preserve(ctx, x, y)
|
||||
#define sexp_gc_release(ctx, x, y)
|
||||
|
||||
#include "gc/include/gc.h"
|
||||
|
|
@ -200,11 +201,28 @@ struct sexp_struct {
|
|||
#else
|
||||
|
||||
#define sexp_gc_var(ctx, x, y) \
|
||||
sexp x = SEXP_FALSE; \
|
||||
struct sexp_gc_var_t y = {&x, &(sexp_context_saves(cxt))}; \
|
||||
sexp_context_saves(cxt) = &y;
|
||||
sexp x = SEXP_FALSE; \
|
||||
struct sexp_gc_var_t 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
|
||||
#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_TRUE SEXP_MAKE_IMMEDIATE(2)
|
||||
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
|
||||
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4)
|
||||
#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* internal use */
|
||||
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(6) /* internal use */
|
||||
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(7) /* internal use */
|
||||
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(8) /* internal use */
|
||||
#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 *****************************/
|
||||
|
||||
|
|
@ -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_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 ****************************/
|
||||
|
||||
#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_cddar(x) (sexp_cdr(sexp_cdar(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)))
|
||||
|
||||
/***************************** general API ****************************/
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue