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

Hygiene change. Removing syntactic closure flattening to

Browse source 
support unhygienic insertion.  Breaks the previous assumption
that syntactic closures were never nested.
This commit is contained in:
Alex Shinn 2014-01-12 19:29:11 +09:00
parent 8e32a64426
commit b638b9f1b4
9 changed files with 111 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

151
eval.c
View file

@ -80,17 +80,21 @@ sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) {
/* Look for the first defined instance of the variable. If not found, */ /* Look for the first defined instance of the variable. If not found, */
/* return the first undefined instance. */ /* return the first undefined instance. */
static sexp sexp_env_cell_loc (sexp env, sexp key, int localp, sexp *varenv) { static sexp sexp_env_cell_loc1 (sexp env, sexp key, int localp, sexp *varenv,
sexp ls, undefined = NULL, undefined_env = NULL; sexp *undefined, sexp *undefined_env) {
sexp ls;
do { do {
#if SEXP_USE_RENAME_BINDINGS #if SEXP_USE_RENAME_BINDINGS
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
if (sexp_car(ls) == key) { if (sexp_car(ls) == key) {
/* export-all hack - if this cell is undefined, only use it if */
/* there is no other defined cell that matches. */
/* TODO: order the environments properly and remove this */
if (sexp_pairp(sexp_cdr(ls)) && sexp_cdr(sexp_cdr(ls)) == SEXP_UNDEF) { if (sexp_pairp(sexp_cdr(ls)) && sexp_cdr(sexp_cdr(ls)) == SEXP_UNDEF) {
if (!undefined) { if (!undefined) {
undefined_env = env; *undefined_env = env;
undefined = sexp_cdr(ls); *undefined = sexp_cdr(ls);
} }
} else { } else {
if (varenv) *varenv = env; if (varenv) *varenv = env;
@ -102,8 +106,8 @@ static sexp sexp_env_cell_loc (sexp env, sexp key, int localp, sexp *varenv) {
if (sexp_car(ls) == key) { if (sexp_car(ls) == key) {
if (sexp_cdr(ls) == SEXP_UNDEF) { if (sexp_cdr(ls) == SEXP_UNDEF) {
if (!undefined) { if (!undefined) {
undefined_env = env; *undefined_env = env;
undefined = ls; *undefined = ls;
} }
} else { } else {
if (varenv) *varenv = env; if (varenv) *varenv = env;
@ -113,16 +117,28 @@ static sexp sexp_env_cell_loc (sexp env, sexp key, int localp, sexp *varenv) {
env = (localp ? NULL : sexp_env_parent(env)); env = (localp ? NULL : sexp_env_parent(env));
} while (env && sexp_envp(env)); } while (env && sexp_envp(env));
if (undefined) {
if (varenv) *varenv = undefined_env;
return undefined;
}
return NULL; return NULL;
} }
sexp sexp_env_cell (sexp env, sexp key, int localp) { static sexp sexp_env_cell_loc (sexp ctx, sexp env, sexp key, int localp, sexp *varenv) {
return sexp_env_cell_loc(env, key, localp, NULL); sexp cell, undefined = NULL, undefined_env = NULL;
cell = sexp_env_cell_loc1(env, key, localp, varenv, &undefined, &undefined_env);
while (!cell && sexp_synclop(key)) {
if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_context_fv(ctx)))
&& sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_synclo_free_vars(key))))
env = sexp_synclo_env(key);
key = sexp_synclo_expr(key);
cell = sexp_env_cell_loc1(env, key, 0, varenv, &undefined, &undefined_env);
}
if (!cell && undefined) {
if (varenv) *varenv = undefined_env;
return undefined;
}
return cell;
}
sexp sexp_env_cell (sexp ctx, sexp env, sexp key, int localp) {
return sexp_env_cell_loc(ctx, env, key, localp, NULL);
} }
static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) { static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) {
@ -164,13 +180,13 @@ sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key,
sexp value, sexp *varenv) { sexp value, sexp *varenv) {
sexp cell = sexp_env_cell_loc(env, key, 0, varenv); sexp cell = sexp_env_cell_loc(ctx, env, key, 0, varenv);
if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv); if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv);
return cell; return cell;
} }
sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { sexp sexp_env_ref (sexp ctx, sexp env, sexp key, sexp dflt) {
sexp cell = sexp_env_cell(env, key, 0); sexp cell = sexp_env_cell(ctx, env, key, 0);
return (cell ? sexp_cdr(cell) : dflt); return (cell ? sexp_cdr(cell) : dflt);
} }
@ -178,7 +194,7 @@ sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
sexp cell, tmp, res = SEXP_VOID; sexp cell, tmp, res = SEXP_VOID;
if (sexp_immutablep(env)) if (sexp_immutablep(env))
return sexp_user_exception(ctx, NULL, "immutable binding", key); return sexp_user_exception(ctx, NULL, "immutable binding", key);
cell = sexp_env_cell(env, key, 1); cell = sexp_env_cell(ctx, env, key, 1);
if (!cell) { if (!cell) {
sexp_env_push(ctx, env, tmp, key, value); sexp_env_push(ctx, env, tmp, key, value);
} else if (sexp_immutablep(cell)) { } else if (sexp_immutablep(cell)) {
@ -267,18 +283,27 @@ static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls));
} }
int sexp_param_index (sexp lambda, sexp name) { int sexp_param_index (sexp ctx, sexp lambda, sexp name) {
sexp ls = sexp_lambda_params(lambda); sexp ls;
int i = 0; int i;
for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) while (1) {
if (sexp_car(ls) == name) i = 0;
ls = sexp_lambda_params(lambda);
for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
if (sexp_car(ls) == name)
return i;
if (ls == name)
return i; return i;
if (ls == name) ls = sexp_lambda_locals(lambda);
return i; for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--)
ls = sexp_lambda_locals(lambda); if (sexp_car(ls) == name)
for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) return i-4;
if (sexp_car(ls) == name) if (sexp_synclop(name))
return i-4; name = sexp_synclo_expr(name);
else
break;
}
sexp_warn(ctx, "can't happen: no argument: ", name);
return -10000; return -10000;
} }
@ -384,7 +409,7 @@ sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv,
if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr))) if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr)))
return expr; return expr;
res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO);
if (sexp_synclop(expr)) { if (SEXP_USE_FLAT_SYNTACTIC_CLOSURES && sexp_synclop(expr)) {
sexp_synclo_env(res) = sexp_synclo_env(expr); sexp_synclo_env(res) = sexp_synclo_env(expr);
sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr); sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr);
sexp_synclo_expr(res) = sexp_synclo_expr(expr); sexp_synclo_expr(res) = sexp_synclo_expr(expr);
@ -566,6 +591,11 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) {
/**************************** identifiers *****************************/ /**************************** identifiers *****************************/
int sexp_idp (sexp x) {
while (sexp_synclop(x)) x = sexp_synclo_expr(x);
return sexp_symbolp(x);
}
sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
return sexp_make_boolean(sexp_idp(x)); return sexp_make_boolean(sexp_idp(x));
} }
@ -596,18 +626,8 @@ sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) { sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
sexp cell1, cell2; sexp cell1, cell2;
cell1 = sexp_env_cell(e1, id1, 0); cell1 = sexp_env_cell(ctx, e1, id1, 0);
if (!cell1 && sexp_synclop(id1)) { cell2 = sexp_env_cell(ctx, e2, id2, 0);
e1 = sexp_synclo_env(id1);
id1 = sexp_synclo_expr(id1);
cell1 = sexp_env_cell(e1, id1, 0);
}
cell2 = sexp_env_cell(e2, id2, 0);
if (!cell2 && sexp_synclop(id2)) {
e2 = sexp_synclo_env(id2);
id2 = sexp_synclo_expr(id2);
cell2 = sexp_env_cell(e2, id2, 0);
}
if (cell1 && (cell1 == cell2)) if (cell1 && (cell1 == cell2))
return SEXP_TRUE; return SEXP_TRUE;
else if (!cell1 && !cell2 && (id1 == id2)) else if (!cell1 && !cell2 && (id1 == id2))
@ -616,10 +636,16 @@ sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id
/* If the identifiers are the same and the cells are either unbound * /* If the identifiers are the same and the cells are either unbound *
* or bound to top-level variables, consider them the same. Local * * or bound to top-level variables, consider them the same. Local *
* (non-toplevel) bindings must still match exactly. */ * (non-toplevel) bindings must still match exactly. */
else if ((id1 == id2) else {
&& (!cell1 || !sexp_lambdap(sexp_cdr(cell1))) while (sexp_synclop(id1))
&& (!cell2 || !sexp_lambdap(sexp_cdr(cell2)))) id1 = sexp_synclo_expr(id1);
return SEXP_TRUE; while (sexp_synclop(id2))
id2 = sexp_synclo_expr(id2);
if ((id1 == id2)
&& (!cell1 || !sexp_lambdap(sexp_cdr(cell1)))
&& (!cell2 || !sexp_lambdap(sexp_cdr(cell2))))
return SEXP_TRUE;
}
#endif #endif
return SEXP_FALSE; return SEXP_FALSE;
} }
@ -681,20 +707,15 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
sexp env = sexp_context_env(ctx), res; sexp env = sexp_context_env(ctx), res;
sexp_gc_var1(cell); sexp_gc_var1(cell);
sexp_gc_preserve1(ctx, cell); sexp_gc_preserve1(ctx, cell);
cell = sexp_env_cell_loc(env, x, 0, varenv); cell = sexp_env_cell_loc(ctx, env, x, 0, varenv);
if (! cell) { if (! cell) {
if (sexp_synclop(x)) { while (sexp_synclop(x)) x = sexp_synclo_expr(x);
if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx)))
&& sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x))))
env = sexp_synclo_env(x);
x = sexp_synclo_expr(x);
}
cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv);
} }
if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) { if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) {
res = sexp_compile_error(ctx, "invalid use of syntax as value", x); res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
} else { } else {
res = sexp_make_ref(ctx, x, cell); res = sexp_make_ref(ctx, sexp_car(cell), cell);
} }
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return res; return res;
@ -853,7 +874,7 @@ static sexp analyze_define (sexp ctx, sexp x, int depth) {
value = analyze_lambda(ctx, tmp, depth); value = analyze_lambda(ctx, tmp, depth);
} else } else
value = analyze(ctx, sexp_caddr(x), depth); value = analyze(ctx, sexp_caddr(x), depth);
tmp = sexp_env_cell_loc(env, name, 0, &varenv); tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv);
ref = sexp_make_ref(ctx, name, tmp); ref = sexp_make_ref(ctx, name, tmp);
if (sexp_exceptionp(ref)) { if (sexp_exceptionp(ref)) {
res = ref; res = ref;
@ -883,7 +904,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
break; break;
} else { } else {
if (sexp_idp(sexp_cadar(ls))) if (sexp_idp(sexp_cadar(ls)))
mac = sexp_env_ref(sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE); mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE);
else else
mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
if (sexp_procedurep(mac)) if (sexp_procedurep(mac))
@ -962,11 +983,7 @@ static sexp analyze (sexp ctx, sexp object, int depth) {
if (sexp_not(sexp_listp(ctx, x))) { if (sexp_not(sexp_listp(ctx, x))) {
res = sexp_compile_error(ctx, "dotted list in source", x); res = sexp_compile_error(ctx, "dotted list in source", x);
} else if (sexp_idp(sexp_car(x))) { } else if (sexp_idp(sexp_car(x))) {
cell = sexp_env_cell(sexp_context_env(ctx), sexp_car(x), 0); cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_car(x), 0);
if (! cell && sexp_synclop(sexp_car(x)))
cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)),
sexp_synclo_expr(sexp_car(x)),
0);
if (! cell) { if (! cell) {
res = analyze_app(ctx, x, depth); res = analyze_app(ctx, x, depth);
if (sexp_exceptionp(res)) if (sexp_exceptionp(res))
@ -1951,7 +1968,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name,
sexp_gc_var1(tmp); sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp); sexp_gc_preserve1(ctx, tmp);
tmp = sexp_intern(ctx, param, -1); tmp = sexp_intern(ctx, param, -1);
tmp = sexp_env_ref(env, tmp, SEXP_FALSE); tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE);
if (sexp_opcodep(tmp)) if (sexp_opcodep(tmp))
res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
@ -2017,7 +2034,7 @@ sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp versio
sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1); sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
sexp_opcode_data(op) = sexp_env_ref(e, sym, SEXP_FALSE); sexp_opcode_data(op) = sexp_env_ref(ctx, e, sym, SEXP_FALSE);
} else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) { } else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) {
sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE); sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE);
} }
@ -2160,7 +2177,7 @@ sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
} }
void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
sexp param = sexp_env_ref(env, name, SEXP_FALSE); sexp param = sexp_env_ref(ctx, env, name, SEXP_FALSE);
if (sexp_opcodep(param)) { if (sexp_opcodep(param)) {
if (! sexp_pairp(sexp_opcode_data(param))) if (! sexp_pairp(sexp_opcode_data(param)))
sexp_opcode_data(param) = sexp_cons(ctx, name, value); sexp_opcode_data(param) = sexp_cons(ctx, name, value);
@ -2264,7 +2281,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
#endif #endif
sexp_global(ctx, SEXP_G_ERR_HANDLER) sexp_global(ctx, SEXP_G_ERR_HANDLER)
= sexp_env_ref(e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE); = sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE);
/* load init.scm */ /* load init.scm */
len = strlen(sexp_init_file); len = strlen(sexp_init_file);
strncpy(init_file, sexp_init_file, len); strncpy(init_file, sexp_init_file, len);
@ -2288,7 +2305,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
} }
if (!sexp_exceptionp(tmp)) { if (!sexp_exceptionp(tmp)) {
sym = sexp_intern(ctx, "repl-import", -1); sym = sexp_intern(ctx, "repl-import", -1);
tmp = sexp_env_ref(tmp, sym, SEXP_VOID); tmp = sexp_env_ref(ctx, tmp, sym, SEXP_VOID);
sym = sexp_intern(ctx, "import", -1); sym = sexp_intern(ctx, "import", -1);
sexp_env_define(ctx, e, sym, tmp); sexp_env_define(ctx, e, sym, tmp);
} }
@ -2335,8 +2352,8 @@ sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from,
} else { } else {
newname = oldname = sexp_car(ls); newname = oldname = sexp_car(ls);
} }
oldcell = sexp_env_cell(to, newname, 0); oldcell = sexp_env_cell(ctx, to, newname, 0);
value = sexp_env_cell(from, oldname, 0); value = sexp_env_cell(ctx, from, oldname, 0);
if (value) { if (value) {
#if SEXP_USE_RENAME_BINDINGS #if SEXP_USE_RENAME_BINDINGS
sexp_env_rename(ctx, to, newname, value); sexp_env_rename(ctx, to, newname, value);

6
include/chibi/eval.h
View file

@ -79,7 +79,7 @@ SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i);
SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size); SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size);
SEXP_API void sexp_stack_trace (sexp ctx, sexp out); SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name);
SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env); SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env); SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env); SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env);
@ -118,8 +118,8 @@ SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, s
SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x);
SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line); SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line);
SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp); SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp);
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt);
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param); SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res); SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res);
SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);

4
include/chibi/features.h
View file

@ -412,6 +412,10 @@
#endif #endif
#endif #endif
#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES
#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0
#endif
#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS #if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
#define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0 #define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0
#endif #endif

5
include/chibi/sexp.h
View file

@ -683,8 +683,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_symbolp(x) (sexp_lsymbolp(x)) #define sexp_symbolp(x) (sexp_lsymbolp(x))
#endif #endif
#define sexp_idp(x) \ SEXP_API int sexp_idp(sexp x);
(sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
#define sexp_portp(x) (sexp_check_tag(x, SEXP_IPORT) || sexp_check_tag(x, SEXP_OPORT)) #define sexp_portp(x) (sexp_check_tag(x, SEXP_IPORT) || sexp_check_tag(x, SEXP_OPORT))
@ -1494,7 +1493,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj
(sexp_proc2)finalizer) (sexp_proc2)finalizer)
#endif #endif
#define sexp_current_error_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE)) #define sexp_current_error_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE))
#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) #define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
/* simplify primitive API interface */ /* simplify primitive API interface */

4
lib/chibi/ast.c
View file

@ -42,13 +42,13 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) { static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
sexp cell; sexp cell;
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
cell = sexp_env_cell(env, id, 0); cell = sexp_env_cell(ctx, env, id, 0);
if (! cell) { if (! cell) {
if (sexp_synclop(id)) { if (sexp_synclop(id)) {
env = sexp_synclo_env(id); env = sexp_synclo_env(id);
id = sexp_synclo_expr(id); id = sexp_synclo_expr(id);
} }
cell = sexp_env_cell(env, id, 0); cell = sexp_env_cell(ctx, env, id, 0);
if (!cell && createp) if (!cell && createp)
cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL); cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL);
} }

3
lib/chibi/heap-stats.c
View file

@ -57,7 +57,8 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
if (printp) if (printp)
out = sexp_parameter_ref(ctx, out = sexp_parameter_ref(ctx,
sexp_env_ref(sexp_context_env(ctx), sexp_env_ref(ctx,
sexp_context_env(ctx),
sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL), sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
SEXP_FALSE)); SEXP_FALSE));

4
lib/srfi/18/threads.c
View file

@ -427,7 +427,7 @@ sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) {
runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER);
if (! sexp_contextp(runner)) { /* ensure the runner exists */ if (! sexp_contextp(runner)) { /* ensure the runner exists */
if (sexp_envp(runner)) { if (sexp_envp(runner)) {
tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0); tmp = sexp_env_cell(ctx, runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0);
if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) {
runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE);
sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner;
@ -623,7 +623,7 @@ sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) {
/**************************************************************************/ /**************************************************************************/
sexp sexp_lookup_named_type (sexp ctx, sexp env, const char *name) { sexp sexp_lookup_named_type (sexp ctx, sexp env, const char *name) {
sexp t = sexp_env_ref(env, sexp_intern(ctx, name, -1), SEXP_FALSE); sexp t = sexp_env_ref(ctx, env, sexp_intern(ctx, name, -1), SEXP_FALSE);
return sexp_make_fixnum((sexp_typep(t)) ? sexp_type_tag(t) : -1); return sexp_make_fixnum((sexp_typep(t)) ? sexp_type_tag(t) : -1);
} }

14
main.c
View file

@ -193,7 +193,7 @@ static sexp sexp_meta_env (sexp ctx) {
} }
static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) { static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) {
sexp res = sexp_env_ref(env, name, SEXP_FALSE); sexp res = sexp_env_ref(ctx, env, name, SEXP_FALSE);
return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : NULL; return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : NULL;
} }
@ -305,7 +305,7 @@ static sexp check_exception (sexp ctx, sexp res) {
advise = sexp_vector_ref(advise, SEXP_ONE); advise = sexp_vector_ref(advise, SEXP_ONE);
if (sexp_envp(advise)) { if (sexp_envp(advise)) {
sym = sexp_intern(ctx, "repl-advise-exception", -1); sym = sexp_intern(ctx, "repl-advise-exception", -1);
advise = sexp_env_ref(advise, sym, SEXP_FALSE); advise = sexp_env_ref(ctx, advise, sym, SEXP_FALSE);
if (sexp_procedurep(advise)) if (sexp_procedurep(advise))
sexp_apply(ctx, advise, tmp=sexp_list2(ctx, res, err)); sexp_apply(ctx, advise, tmp=sexp_list2(ctx, res, err));
} }
@ -503,7 +503,7 @@ void run_main (int argc, char **argv) {
if (! sexp_oportp(out)) if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env); out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write_string(ctx, sexp_version_string, out); sexp_write_string(ctx, sexp_version_string, out);
tmp = sexp_env_ref(env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL); tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL);
sexp_write(ctx, tmp, out); sexp_write(ctx, tmp, out);
sexp_newline(ctx, out); sexp_newline(ctx, out);
return; return;
@ -565,11 +565,11 @@ void run_main (int argc, char **argv) {
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_context_env(ctx) = env; sexp_context_env(ctx) = env;
sym = sexp_intern(ctx, "repl-import", -1); sym = sexp_intern(ctx, "repl-import", -1);
tmp = sexp_env_ref(sexp_meta_env(ctx), sym, SEXP_VOID); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
sym = sexp_intern(ctx, "import", -1); sym = sexp_intern(ctx, "import", -1);
sexp_env_define(ctx, env, sym, tmp); sexp_env_define(ctx, env, sym, tmp);
sym = sexp_intern(ctx, "cond-expand", -1); sym = sexp_intern(ctx, "cond-expand", -1);
tmp = sexp_env_ref(sexp_meta_env(ctx), sym, SEXP_VOID); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
sexp_env_define(ctx, env, sym, tmp); sexp_env_define(ctx, env, sym, tmp);
} }
#endif #endif
@ -578,7 +578,7 @@ void run_main (int argc, char **argv) {
#if SEXP_USE_MODULES #if SEXP_USE_MODULES
/* use scheme load if possible for better stack traces */ /* use scheme load if possible for better stack traces */
sym = sexp_intern(ctx, "load", -1); sym = sexp_intern(ctx, "load", -1);
tmp = sexp_env_ref(sexp_meta_env(ctx), sym, SEXP_FALSE); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE);
if (sexp_procedurep(tmp)) { if (sexp_procedurep(tmp)) {
sym = sexp_c_string(ctx, argv[i], -1); sym = sexp_c_string(ctx, argv[i], -1);
sym = sexp_list2(ctx, sym, env); sym = sexp_list2(ctx, sym, env);
@ -593,7 +593,7 @@ void run_main (int argc, char **argv) {
/* SRFI-22: run main if specified */ /* SRFI-22: run main if specified */
if (main_symbol) { if (main_symbol) {
sym = sexp_intern(ctx, main_symbol, -1); sym = sexp_intern(ctx, main_symbol, -1);
tmp = sexp_env_ref(env, sym, SEXP_FALSE); tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE);
if (sexp_procedurep(tmp)) { if (sexp_procedurep(tmp)) {
args = sexp_list1(ctx, args); args = sexp_list1(ctx, args);
check_exception(ctx, sexp_apply(ctx, tmp, args)); check_exception(ctx, sexp_apply(ctx, tmp, args));

10
vm.c
View file

@ -214,7 +214,7 @@ static void generate_non_global_ref (sexp ctx, sexp name, sexp cell,
if (loc == lambda && sexp_lambdap(lambda)) { if (loc == lambda && sexp_lambdap(lambda)) {
/* local ref */ /* local ref */
sexp_emit(ctx, SEXP_OP_LOCAL_REF); sexp_emit(ctx, SEXP_OP_LOCAL_REF);
sexp_emit_word(ctx, sexp_param_index(lambda, name)); sexp_emit_word(ctx, sexp_param_index(ctx, lambda, name));
} else { } else {
/* closure ref */ /* closure ref */
for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
@ -277,7 +277,7 @@ static void generate_set (sexp ctx, sexp set) {
} else { } else {
/* internally defined variable */ /* internally defined variable */
sexp_emit(ctx, SEXP_OP_LOCAL_SET); sexp_emit(ctx, SEXP_OP_LOCAL_SET);
sexp_emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); sexp_emit_word(ctx, sexp_param_index(ctx, lambda, sexp_ref_name(ref)));
} }
} }
sexp_emit_push(ctx, SEXP_VOID); sexp_emit_push(ctx, SEXP_VOID);
@ -476,7 +476,7 @@ static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp ap
} }
for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
sexp_emit(ctx, SEXP_OP_LOCAL_SET); sexp_emit(ctx, SEXP_OP_LOCAL_SET);
sexp_emit_word(ctx, sexp_param_index(lam, sexp_car(ls1))); sexp_emit_word(ctx, sexp_param_index(ctx, lam, sexp_car(ls1)));
} }
/* drop the current result and jump */ /* drop the current result and jump */
@ -623,7 +623,7 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
} }
/* box mutable vars */ /* box mutable vars */
for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
k = sexp_param_index(lambda, sexp_car(ls)); k = sexp_param_index(ctx, lambda, sexp_car(ls));
sexp_emit(ctx2, SEXP_OP_LOCAL_REF); sexp_emit(ctx2, SEXP_OP_LOCAL_REF);
sexp_emit_word(ctx2, k); sexp_emit_word(ctx2, k);
sexp_emit_push(ctx2, sexp_car(ls)); sexp_emit_push(ctx2, sexp_car(ls));
@ -736,7 +736,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
} else { } else {
sexp_context_env(ctx2) = env; sexp_context_env(ctx2) = env;
for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls), 0)); ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(ctx, env, sexp_car(ls), 0));
if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref); if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
} }
if (!sexp_exceptionp(refs)) if (!sexp_exceptionp(refs))