mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
additions in preparation for module system
This commit is contained in:
Alex Shinn
parent
34a9b15645
commit
6376198e92
1 changed files with 82 additions and 44 deletions
126
eval.c
126
eval.c
|
|
@ -26,8 +26,25 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
|
|||
|
||||
static sexp analyze (sexp ctx, sexp x);
|
||||
static void generate (sexp ctx, sexp x);
|
||||
static sexp sexp_make_env (sexp ctx);
|
||||
static sexp sexp_make_null_env (sexp ctx, sexp version);
|
||||
static sexp sexp_make_standard_env (sexp ctx, sexp version);
|
||||
static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls);
|
||||
|
||||
static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
|
||||
sexp exn;
|
||||
sexp_gc_var(ctx, irritants, s_irr);
|
||||
sexp_gc_var(ctx, msg, s_msg);
|
||||
sexp_gc_preserve(ctx, irritants, s_irr);
|
||||
sexp_gc_preserve(ctx, msg, s_msg);
|
||||
irritants = sexp_list1(ctx, obj);
|
||||
msg = sexp_c_string(ctx, message, -1);
|
||||
exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants,
|
||||
SEXP_FALSE, (sexp_pairp(obj) ?
|
||||
sexp_pair_source(obj) : SEXP_FALSE));
|
||||
sexp_gc_release(ctx, irritants, s_irr);
|
||||
return exn;
|
||||
}
|
||||
|
||||
/********************** environment utilities ***************************/
|
||||
|
||||
|
|
@ -68,15 +85,19 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) {
|
|||
|
||||
static void env_define(sexp ctx, sexp e, sexp key, sexp value) {
|
||||
sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e));
|
||||
sexp_gc_var(ctx, tmp, s_tmp);
|
||||
sexp_gc_preserve(ctx, tmp, s_tmp);
|
||||
if (sexp_truep(cell))
|
||||
sexp_cdr(cell) = value;
|
||||
else {
|
||||
tmp = sexp_cons(ctx, key, value);
|
||||
sexp_push(ctx, sexp_env_bindings(e), tmp);
|
||||
if (sexp_immutablep(e)) {
|
||||
fprintf(stderr, "ERROR: immutable environment\n");
|
||||
} else {
|
||||
sexp_gc_var(ctx, tmp, s_tmp);
|
||||
sexp_gc_preserve(ctx, tmp, s_tmp);
|
||||
if (sexp_truep(cell))
|
||||
sexp_cdr(cell) = value;
|
||||
else {
|
||||
tmp = sexp_cons(ctx, key, value);
|
||||
sexp_push(ctx, sexp_env_bindings(e), tmp);
|
||||
}
|
||||
sexp_gc_release(ctx, tmp, s_tmp);
|
||||
}
|
||||
sexp_gc_release(ctx, tmp, s_tmp);
|
||||
}
|
||||
|
||||
static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
||||
|
|
@ -213,7 +234,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
|
|||
|
||||
static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) {
|
||||
sexp res;
|
||||
if (sexp_synclop(expr))
|
||||
if (! (sexp_symbolp(expr) || sexp_pairp(expr)))
|
||||
return expr;
|
||||
res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO);
|
||||
sexp_synclo_env(res) = env;
|
||||
|
|
@ -360,21 +381,6 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) {
|
|||
|
||||
/************************* the compiler ***************************/
|
||||
|
||||
static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
|
||||
sexp exn;
|
||||
sexp_gc_var(ctx, irritants, s_irr);
|
||||
sexp_gc_var(ctx, msg, s_msg);
|
||||
sexp_gc_preserve(ctx, irritants, s_irr);
|
||||
sexp_gc_preserve(ctx, msg, s_msg);
|
||||
irritants = sexp_list1(ctx, obj);
|
||||
msg = sexp_c_string(ctx, message, -1);
|
||||
exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants,
|
||||
SEXP_FALSE, (sexp_pairp(obj) ?
|
||||
sexp_pair_source(obj) : SEXP_FALSE));
|
||||
sexp_gc_release(ctx, irritants, s_irr);
|
||||
return exn;
|
||||
}
|
||||
|
||||
static sexp analyze_app (sexp ctx, sexp x) {
|
||||
sexp_gc_var(ctx, res, s_res);
|
||||
sexp_gc_var(ctx, tmp, s_tmp);
|
||||
|
|
@ -570,6 +576,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x);
|
||||
res = SEXP_VOID;
|
||||
} else {
|
||||
if (sexp_synclop(name)) name = sexp_synclo_expr(name);
|
||||
env_cell_create(ctx, env, name, SEXP_VOID);
|
||||
if (sexp_pairp(sexp_cadr(x))) {
|
||||
tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
|
||||
|
|
@ -591,7 +598,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
}
|
||||
|
||||
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
|
||||
sexp res = SEXP_VOID;
|
||||
sexp res = SEXP_VOID, name;
|
||||
sexp_gc_var(eval_ctx, proc, s_proc);
|
||||
sexp_gc_var(eval_ctx, mac, s_mac);
|
||||
sexp_gc_var(eval_ctx, tmp, s_tmp);
|
||||
|
|
@ -605,8 +612,11 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
|
|||
} else {
|
||||
proc = sexp_eval(eval_ctx, sexp_cadar(ls));
|
||||
if (sexp_procedurep(proc)) {
|
||||
name = sexp_caar(ls);
|
||||
if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx)))
|
||||
name = sexp_synclo_expr(name);
|
||||
mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx));
|
||||
tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
|
||||
tmp = sexp_cons(eval_ctx, name, mac);
|
||||
sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
|
||||
} else {
|
||||
res = (sexp_exceptionp(proc) ? proc
|
||||
|
|
@ -753,13 +763,13 @@ static sexp analyze (sexp ctx, sexp object) {
|
|||
} else if (sexp_idp(x)) {
|
||||
res = analyze_var_ref(ctx, x);
|
||||
} else if (sexp_synclop(x)) {
|
||||
ctx = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
||||
sexp_context_env(ctx) = sexp_synclo_env(x);
|
||||
sexp_context_fv(ctx) = sexp_append2(ctx,
|
||||
tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
||||
sexp_context_env(tmp) = sexp_synclo_env(x);
|
||||
sexp_context_fv(tmp) = sexp_append2(tmp,
|
||||
sexp_synclo_free_vars(x),
|
||||
sexp_context_fv(ctx));
|
||||
sexp_context_fv(tmp));
|
||||
x = sexp_synclo_expr(x);
|
||||
goto loop;
|
||||
res = analyze(tmp, x);
|
||||
} else {
|
||||
res = x;
|
||||
}
|
||||
|
|
@ -1263,9 +1273,10 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
loop:
|
||||
#ifdef DEBUG_VM
|
||||
if (sexp_context_tracep(ctx)) {
|
||||
sexp_print_stack(stack, top, fp,
|
||||
sexp_print_stack(ctx, stack, top, fp,
|
||||
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<=OP_NUM_OPCODES) ?
|
||||
reverse_opcode_names[*ip] : "UNKNOWN");
|
||||
}
|
||||
#endif
|
||||
switch (*ip++) {
|
||||
|
|
@ -1995,6 +2006,13 @@ static sexp sexp_close_port (sexp ctx, sexp port) {
|
|||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
static sexp sexp_file_exists_p (sexp ctx, sexp path) {
|
||||
struct stat buf;
|
||||
if (! sexp_stringp(path))
|
||||
return sexp_type_exception(ctx, "not a string", path);
|
||||
return (stat(sexp_string_data(path), &buf) ? SEXP_FALSE : SEXP_TRUE);
|
||||
}
|
||||
|
||||
void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) {
|
||||
sexp x;
|
||||
for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
|
||||
|
|
@ -2181,12 +2199,17 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
|
|||
return res;
|
||||
}
|
||||
|
||||
static sexp sexp_make_null_env (sexp ctx, sexp version) {
|
||||
sexp_uint_t i;
|
||||
static sexp sexp_make_env (sexp ctx) {
|
||||
sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
||||
sexp_env_lambda(e) = NULL;
|
||||
sexp_env_parent(e) = NULL;
|
||||
sexp_env_bindings(e) = SEXP_NULL;
|
||||
return e;
|
||||
}
|
||||
|
||||
static sexp sexp_make_null_env (sexp ctx, sexp version) {
|
||||
sexp_uint_t i;
|
||||
sexp e = sexp_make_env(ctx);
|
||||
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++)
|
||||
env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])),
|
||||
sexp_copy_core(ctx, &core_forms[i]));
|
||||
|
|
@ -2222,6 +2245,8 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
env_define(ctx, e, the_cur_err_symbol,
|
||||
sexp_make_output_port(ctx, stderr, SEXP_FALSE));
|
||||
env_define(ctx, e, the_interaction_env_symbol, e);
|
||||
env_define(ctx, e, sexp_intern(ctx, "*module-directory*"),
|
||||
sexp_c_string(ctx, sexp_module_dir, -1));
|
||||
/* add default exception handler */
|
||||
err_cell = env_cell(e, the_cur_err_symbol);
|
||||
perr_cell = env_cell(e, sexp_intern(ctx, "print-exception"));
|
||||
|
|
@ -2248,6 +2273,17 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
return e;
|
||||
}
|
||||
|
||||
static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) {
|
||||
if (! sexp_envp(to)) to = sexp_context_env(ctx);
|
||||
if (! sexp_envp(from)) from = sexp_context_env(ctx);
|
||||
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
if (sexp_pairp(sexp_car(ls)))
|
||||
env_define(ctx, to, sexp_caar(ls), env_global_ref(from, sexp_cdar(ls), SEXP_FALSE));
|
||||
else
|
||||
env_define(ctx, to, sexp_car(ls), env_global_ref(from, sexp_car(ls), SEXP_FALSE));
|
||||
return SEXP_UNDEF;
|
||||
}
|
||||
|
||||
/************************** eval interface ****************************/
|
||||
|
||||
sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
||||
|
|
@ -2279,10 +2315,8 @@ sexp sexp_compile (sexp ctx, sexp x) {
|
|||
res = ast;
|
||||
} else {
|
||||
free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */
|
||||
ctx2 = sexp_make_context(ctx,sexp_context_stack(ctx),sexp_context_env(ctx));
|
||||
sexp_context_parent(ctx2) = ctx;
|
||||
generate(ctx2, ast);
|
||||
res = finalize_bytecode(ctx2);
|
||||
generate(ctx, ast);
|
||||
res = finalize_bytecode(ctx);
|
||||
vec = sexp_make_vector(ctx, 0, SEXP_VOID);
|
||||
res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
|
||||
res, vec);
|
||||
|
|
@ -2292,18 +2326,20 @@ sexp sexp_compile (sexp ctx, sexp x) {
|
|||
}
|
||||
|
||||
sexp sexp_eval (sexp ctx, sexp obj) {
|
||||
sexp res;
|
||||
sexp res, ctx2;
|
||||
sexp_gc_var(ctx, thunk, s_thunk);
|
||||
sexp_gc_preserve(ctx, thunk, s_thunk);
|
||||
thunk = sexp_compile(ctx, obj);
|
||||
ctx2 = sexp_make_context(ctx, NULL, sexp_context_env(ctx));
|
||||
sexp_context_parent(ctx2) = ctx;
|
||||
thunk = sexp_compile(ctx2, obj);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(ctx, thunk,
|
||||
env_global_ref(sexp_context_env(ctx),
|
||||
sexp_print_exception(ctx2, thunk,
|
||||
env_global_ref(sexp_context_env(ctx2),
|
||||
the_cur_err_symbol,
|
||||
SEXP_FALSE));
|
||||
res = thunk;
|
||||
} else {
|
||||
res = sexp_apply(ctx, thunk, SEXP_NULL);
|
||||
res = sexp_apply(ctx2, thunk, SEXP_NULL);
|
||||
}
|
||||
sexp_gc_release(ctx, thunk, s_thunk);
|
||||
return res;
|
||||
|
|
@ -2347,5 +2383,7 @@ void sexp_scheme_init (void) {
|
|||
sexp_make_integer(0),
|
||||
finalize_bytecode(ctx),
|
||||
sexp_make_vector(ctx, 0, SEXP_VOID));
|
||||
sexp_bytecode_name(sexp_procedure_code(final_resumer))
|
||||
= sexp_intern(ctx, "final-resumer");
|
||||
}
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue