mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
adding optional strict top-level matching for syntax-rules literals
This commit is contained in:
Alex Shinn
parent
c80d1daf8c
commit
c5126fb2b0
12 changed files with 147 additions and 78 deletions
158
eval.c
158
eval.c
|
|
@ -50,23 +50,42 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to) {
|
|||
|
||||
/********************** environment utilities ***************************/
|
||||
|
||||
static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) {
|
||||
static sexp sexp_env_cell_loc (sexp env, sexp key, int localp, sexp *varenv) {
|
||||
sexp ls;
|
||||
|
||||
do {
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
if (sexp_car(ls) == key) {
|
||||
if (varenv) *varenv = env;
|
||||
return sexp_cdr(ls);
|
||||
}
|
||||
#endif
|
||||
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
if (sexp_car(ls) == key) {
|
||||
if (varenv) *varenv = env;
|
||||
return ls;
|
||||
}
|
||||
env = sexp_env_parent(env);
|
||||
env = (localp ? NULL : sexp_env_parent(env));
|
||||
} while (env);
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
sexp sexp_env_cell (sexp env, sexp key) {
|
||||
return sexp_env_cell_loc(env, key, NULL);
|
||||
sexp sexp_env_cell (sexp env, sexp key, int localp) {
|
||||
return sexp_env_cell_loc(env, key, localp, NULL);
|
||||
}
|
||||
|
||||
static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) {
|
||||
sexp ls1=NULL, ls2;
|
||||
for (ls2=sexp_env_bindings(env); sexp_pairp(ls2);
|
||||
ls1=ls2, ls2=sexp_env_next_cell(ls2))
|
||||
if (sexp_car(ls2) == key) {
|
||||
if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2);
|
||||
else sexp_env_bindings(env) = sexp_env_next_cell(ls2);
|
||||
return SEXP_TRUE;
|
||||
}
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
|
||||
static sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
|
||||
|
|
@ -75,6 +94,13 @@ static sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
|
|||
while (sexp_env_lambda(env) || sexp_env_syntactic_p(env))
|
||||
env = sexp_env_parent(env);
|
||||
if (varenv) *varenv = env;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
if (sexp_car(ls) == key) {
|
||||
sexp_car(ls) = SEXP_FALSE;
|
||||
break;
|
||||
}
|
||||
#endif
|
||||
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
if (sexp_car(ls) == key)
|
||||
return ls;
|
||||
|
|
@ -86,60 +112,51 @@ static sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
|
|||
|
||||
static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key,
|
||||
sexp value, sexp *varenv) {
|
||||
sexp cell = sexp_env_cell_loc(env, key, varenv);
|
||||
sexp cell = sexp_env_cell_loc(env, key, 0, varenv);
|
||||
if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv);
|
||||
return cell;
|
||||
}
|
||||
|
||||
sexp sexp_env_ref (sexp env, sexp key, sexp dflt) {
|
||||
sexp cell = sexp_env_cell(env, key);
|
||||
sexp cell = sexp_env_cell(env, key, 0);
|
||||
return (cell ? sexp_cdr(cell) : dflt);
|
||||
}
|
||||
|
||||
sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) {
|
||||
while (sexp_env_lambda(env) && sexp_env_parent(env))
|
||||
env = sexp_env_parent(env);
|
||||
return sexp_env_ref(env, key, dflt);
|
||||
}
|
||||
|
||||
sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
|
||||
sexp cell=SEXP_FALSE, res=SEXP_VOID;
|
||||
sexp_gc_var2(ls1, ls2);
|
||||
if (sexp_immutablep(env)) {
|
||||
sexp cell, tmp, res = SEXP_VOID;
|
||||
if (sexp_immutablep(env))
|
||||
return sexp_user_exception(ctx, NULL, "immutable binding", key);
|
||||
cell = sexp_env_cell(env, key, 1);
|
||||
if (!cell) {
|
||||
sexp_env_push(ctx, env, tmp, key, value);
|
||||
} else if (sexp_immutablep(cell)) {
|
||||
res = sexp_user_exception(ctx, NULL, "immutable binding", key);
|
||||
} else {
|
||||
sexp_gc_preserve2(ctx, ls1, ls2);
|
||||
for (ls1=NULL, ls2=sexp_env_bindings(env); sexp_pairp(ls2);
|
||||
ls1=ls2, ls2=sexp_env_next_cell(ls2))
|
||||
if (sexp_car(ls2) == key) {
|
||||
cell = ls2;
|
||||
break;
|
||||
}
|
||||
if (sexp_truep(cell)) {
|
||||
if (sexp_immutablep(cell)) {
|
||||
res = sexp_user_exception(ctx, NULL, "immutable binding", key);
|
||||
} else if ((sexp_corep(value) || sexp_macrop(value))
|
||||
&& !(sexp_corep(sexp_cdr(cell))
|
||||
|| sexp_macrop(sexp_cdr(cell)))) {
|
||||
if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2);
|
||||
else sexp_env_bindings(env) = sexp_env_next_cell(ls2);
|
||||
sexp_env_push(ctx, env, ls2, key, value);
|
||||
} else if (sexp_syntacticp(value) && !sexp_syntacticp(sexp_cdr(cell))) {
|
||||
sexp_env_undefine(ctx, env, key);
|
||||
sexp_env_push(ctx, env, tmp, key, value);
|
||||
} else {
|
||||
sexp_cdr(cell) = value;
|
||||
}
|
||||
} else {
|
||||
sexp_env_push(ctx, env, ls2, key, value);
|
||||
}
|
||||
sexp_gc_release2(ctx);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value) {
|
||||
sexp tmp;
|
||||
sexp_env_push_rename(ctx, env, tmp, key, value);
|
||||
return SEXP_VOID;
|
||||
}
|
||||
#endif
|
||||
|
||||
sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) {
|
||||
sexp ls;
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
res = SEXP_NULL;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
sexp_push(ctx, res, sexp_cadr(ls));
|
||||
#endif
|
||||
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
sexp_push(ctx, res, sexp_car(ls));
|
||||
sexp_gc_release1(ctx);
|
||||
|
|
@ -152,6 +169,9 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
|||
e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
||||
sexp_env_parent(e) = env;
|
||||
sexp_env_bindings(e) = SEXP_NULL;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp_env_renames(e) = SEXP_NULL;
|
||||
#endif
|
||||
for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
|
||||
sexp_env_push(ctx, e, tmp, sexp_car(vars), value);
|
||||
sexp_gc_release2(ctx);
|
||||
|
|
@ -443,22 +463,30 @@ sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
|
|||
}
|
||||
|
||||
sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) {
|
||||
sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE;
|
||||
if (sexp_synclop(id1)) {
|
||||
sexp cell1, cell2;
|
||||
cell1 = sexp_env_cell(e1, id1, 0);
|
||||
if (!cell1 && sexp_synclop(id1)) {
|
||||
e1 = sexp_synclo_env(id1);
|
||||
id1 = sexp_synclo_expr(id1);
|
||||
cell1 = sexp_env_cell(e1, id1, 0);
|
||||
}
|
||||
if (sexp_synclop(id2)) {
|
||||
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);
|
||||
}
|
||||
cell = sexp_env_cell(e1, id1);
|
||||
if (cell && sexp_lambdap(sexp_cdr(cell)))
|
||||
lam1 = sexp_cdr(cell);
|
||||
cell = sexp_env_cell(e2, id2);
|
||||
if (cell && sexp_lambdap(sexp_cdr(cell)))
|
||||
lam2 = sexp_cdr(cell);
|
||||
return sexp_make_boolean((id1 == id2) && (lam1 == lam2));
|
||||
if (cell1 && (cell1 == cell2))
|
||||
return SEXP_TRUE;
|
||||
else if (!cell1 && !cell2 && (id1 == id2))
|
||||
return SEXP_TRUE;
|
||||
#if ! SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
||||
else if (cell1 && !sexp_lambdap(sexp_cdr(cell1))
|
||||
&& cell2 && !sexp_lambdap(sexp_cdr(cell2))
|
||||
&& (id1 == id2))
|
||||
return SEXP_TRUE;
|
||||
#endif
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
|
||||
/************************* the compiler ***************************/
|
||||
|
|
@ -513,7 +541,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
|
|||
sexp env = sexp_context_env(ctx), res;
|
||||
sexp_gc_var1(cell);
|
||||
sexp_gc_preserve1(ctx, cell);
|
||||
cell = sexp_env_cell_loc(env, x, varenv);
|
||||
cell = sexp_env_cell_loc(env, x, 0, varenv);
|
||||
if (! cell) {
|
||||
if (sexp_synclop(x)) {
|
||||
if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx)))
|
||||
|
|
@ -659,7 +687,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
res = SEXP_VOID;
|
||||
} else {
|
||||
if (sexp_synclop(name)) name = sexp_synclo_expr(name);
|
||||
sexp_env_cell_define(ctx, env, name, SEXP_VOID, NULL);
|
||||
sexp_env_cell_define(ctx, env, name, SEXP_VOID, &varenv);
|
||||
if (sexp_pairp(sexp_cadr(x))) {
|
||||
tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
|
||||
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
|
||||
|
|
@ -667,8 +695,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
value = analyze_lambda(ctx, tmp);
|
||||
} else
|
||||
value = analyze(ctx, sexp_caddr(x));
|
||||
tmp = sexp_env_cell_loc(env, name, &varenv);
|
||||
if (!tmp) tmp = sexp_env_cell_create(ctx, env, name, SEXP_UNDEF, &varenv);
|
||||
tmp = sexp_env_cell_loc(env, name, 0, &varenv);
|
||||
ref = sexp_make_ref(ctx, name, tmp);
|
||||
if (sexp_exceptionp(ref)) {
|
||||
res = ref;
|
||||
|
|
@ -734,6 +761,9 @@ static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) {
|
|||
sexp_env_syntactic_p(env) = 1;
|
||||
sexp_env_parent(env) = sexp_context_env(ctx);
|
||||
sexp_env_bindings(env) = SEXP_NULL;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp_env_renames(env) = SEXP_NULL;
|
||||
#endif
|
||||
ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
||||
sexp_context_env(ctx2) = env;
|
||||
tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2);
|
||||
|
|
@ -761,10 +791,11 @@ static sexp analyze (sexp ctx, sexp object) {
|
|||
if (sexp_not(sexp_listp(ctx, x))) {
|
||||
res = sexp_compile_error(ctx, "dotted list in source", x);
|
||||
} else if (sexp_idp(sexp_car(x))) {
|
||||
cell = sexp_env_cell(sexp_context_env(ctx), sexp_car(x));
|
||||
cell = sexp_env_cell(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)));
|
||||
sexp_synclo_expr(sexp_car(x)),
|
||||
0);
|
||||
if (! cell) {
|
||||
res = analyze_app(ctx, x);
|
||||
if (sexp_exceptionp(res))
|
||||
|
|
@ -1494,6 +1525,9 @@ sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) {
|
|||
sexp_env_lambda(e) = NULL;
|
||||
sexp_env_parent(e) = NULL;
|
||||
sexp_env_bindings(e) = SEXP_NULL;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp_env_renames(e) = SEXP_NULL;
|
||||
#endif
|
||||
return e;
|
||||
}
|
||||
|
||||
|
|
@ -1750,9 +1784,15 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se
|
|||
sexp_env_parent(to) = value;
|
||||
sexp_immutablep(value) = 1;
|
||||
sexp_env_bindings(value) = sexp_env_bindings(from);
|
||||
sexp_env_renames(value) = sexp_env_renames(from);
|
||||
} else {
|
||||
for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
||||
for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) {
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp_env_rename(ctx, to, sexp_car(ls), ls);
|
||||
#else
|
||||
sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls));
|
||||
#endif
|
||||
}
|
||||
}
|
||||
} else {
|
||||
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
||||
|
|
@ -1761,9 +1801,13 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se
|
|||
} else {
|
||||
newname = oldname = sexp_car(ls);
|
||||
}
|
||||
value = sexp_env_ref(from, oldname, SEXP_UNDEF);
|
||||
if (value != SEXP_UNDEF) {
|
||||
sexp_env_define(ctx, to, newname, value);
|
||||
value = sexp_env_cell(from, oldname, 0);
|
||||
if (value) {
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp_env_rename(ctx, to, newname, value);
|
||||
#else
|
||||
sexp_env_define(ctx, to, newname, sexp_cdr(value));
|
||||
#endif
|
||||
#if SEXP_USE_WARN_UNDEFS
|
||||
} else {
|
||||
sexp_warn(ctx, "importing undefined variable: ", oldname);
|
||||
|
|
|
|||
|
|
@ -164,9 +164,8 @@ SEXP_API sexp sexp_open_input_file_op(sexp ctx sexp_api_params(self, n), sexp x)
|
|||
SEXP_API sexp sexp_open_output_file_op(sexp ctx sexp_api_params(self, n), sexp x);
|
||||
SEXP_API sexp sexp_close_port_op(sexp ctx sexp_api_params(self, n), sexp x);
|
||||
SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
|
||||
SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
|
||||
SEXP_API sexp sexp_env_cell (sexp env, sexp sym, int localp);
|
||||
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
|
||||
SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
|
||||
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
|
||||
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to);
|
||||
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
|
||||
|
|
@ -179,8 +178,11 @@ SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int
|
|||
|
||||
SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
|
||||
|
||||
#define sexp_env_key(x) sexp_car(x)
|
||||
#define sexp_env_value(x) sexp_cdr(x)
|
||||
#define sexp_env_next_cell(x) sexp_pair_source(x)
|
||||
#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp)
|
||||
#define sexp_env_push_rename(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_renames(env), sexp_env_renames(env)=tmp)
|
||||
|
||||
#if SEXP_USE_TYPE_DEFS
|
||||
SEXP_API sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type);
|
||||
|
|
|
|||
|
|
@ -348,6 +348,18 @@
|
|||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
||||
#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
|
||||
#endif
|
||||
|
||||
#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
||||
#define SEXP_USE_RENAME_BINDINGS 1
|
||||
#else
|
||||
#ifndef SEXP_USE_RENAME_BINDINGS
|
||||
#define SEXP_USE_RENAME_BINDINGS 0
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_EXTENDED_FCALL
|
||||
#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -300,6 +300,9 @@ struct sexp_struct {
|
|||
/* runtime types */
|
||||
struct {
|
||||
sexp parent, lambda, bindings;
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
sexp renames;
|
||||
#endif
|
||||
} env;
|
||||
struct {
|
||||
sexp_uint_t length;
|
||||
|
|
@ -549,6 +552,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE))
|
||||
#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE))
|
||||
#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO))
|
||||
#define sexp_syntacticp(x) (sexp_corep(x) || sexp_macrop(x))
|
||||
#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO))
|
||||
#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA))
|
||||
#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND))
|
||||
|
|
@ -730,6 +734,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
|
|||
#define sexp_env_syntactic_p(x) ((x)->syntacticp)
|
||||
#define sexp_env_parent(x) (sexp_field(x, env, SEXP_ENV, parent))
|
||||
#define sexp_env_bindings(x) (sexp_field(x, env, SEXP_ENV, bindings))
|
||||
#define sexp_env_renames(x) (sexp_field(x, env, SEXP_ENV, renames))
|
||||
#define sexp_env_local_p(x) (sexp_env_parent(x))
|
||||
#define sexp_env_global_p(x) (! sexp_env_local_p(x))
|
||||
#define sexp_env_lambda(x) (sexp_field(x, env, SEXP_ENV, lambda))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
|
|||
}
|
||||
|
||||
static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) {
|
||||
sexp cell = sexp_env_cell(env, id);
|
||||
sexp cell = sexp_env_cell(env, id, 0);
|
||||
while ((! cell) && sexp_synclop(id)) {
|
||||
env = sexp_synclo_env(id);
|
||||
id = sexp_synclo_expr(id);
|
||||
|
|
|
|||
|
|
@ -56,9 +56,10 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
|
|||
sexp_gc_var3(res, tmp, name);
|
||||
|
||||
if (printp)
|
||||
out = sexp_env_global_ref(sexp_context_env(ctx),
|
||||
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL),
|
||||
SEXP_FALSE);
|
||||
out = sexp_parameter_ref(ctx,
|
||||
sexp_env_ref(sexp_context_env(ctx),
|
||||
sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
|
||||
SEXP_FALSE));
|
||||
|
||||
/* run gc once to remove unused variables */
|
||||
sexp_gc(ctx, &freed);
|
||||
|
|
|
|||
|
|
@ -11,4 +11,3 @@
|
|||
(import-immutable (scheme))
|
||||
(import (srfi 39) (srfi 98) (chibi time) (chibi ast))
|
||||
(include "test.scm"))
|
||||
|
||||
|
|
|
|||
|
|
@ -62,14 +62,10 @@
|
|||
((and (pair? (cdr x)) (pair? (cadr x)))
|
||||
(if (memq (car x) '(only except rename))
|
||||
(let* ((mod-name+imports (resolve-import (cadr x)))
|
||||
(imp-ids (cdr mod-name+imports))
|
||||
(imp-ids (if (and (not imp-ids) (not (eq? 'only (car x))))
|
||||
(begin
|
||||
(set-cdr! mod-name+imports
|
||||
(imp-ids (or (cdr mod-name+imports)
|
||||
(and (not (eq? 'only (car x)))
|
||||
(module-exports
|
||||
(find-module (car mod-name+imports))))
|
||||
(cdr mod-name+imports))
|
||||
imp-ids)))
|
||||
(find-module (car mod-name+imports)))))))
|
||||
(cons (car mod-name+imports)
|
||||
(case (car x)
|
||||
((only)
|
||||
|
|
@ -81,7 +77,7 @@
|
|||
((rename)
|
||||
(map (lambda (i)
|
||||
(let ((rename (assq (to-id i) (cddr x))))
|
||||
(if rename (cons (cdr rename) (from-id i)) i)))
|
||||
(if rename (cons (cadr rename) (from-id i)) i)))
|
||||
imp-ids)))))
|
||||
(error "invalid import modifier" x)))
|
||||
((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x)))
|
||||
|
|
@ -116,7 +112,11 @@
|
|||
(mod2 (load-module (car mod2-name+imports))))
|
||||
(%env-copy! env (module-env mod2) (cdr mod2-name+imports)
|
||||
(eq? (car x) 'import-immutable))))
|
||||
(cdr x)))
|
||||
(cdr x)))))
|
||||
(module-meta-data mod))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(case (and (pair? x) (car x))
|
||||
((include)
|
||||
(load-modules (cdr x) ""))
|
||||
((include-shared)
|
||||
|
|
|
|||
|
|
@ -640,7 +640,9 @@
|
|||
(cond
|
||||
((identifier? p)
|
||||
(if (any (lambda (l) (compare p l)) lits)
|
||||
(list _and (list _compare v (list _quote p)) (k vars))
|
||||
(list _and
|
||||
(list _compare v (list _rename (list _quote p)))
|
||||
(k vars))
|
||||
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))
|
||||
((ellipsis? p)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -377,7 +377,7 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) {
|
|||
runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER);
|
||||
if (! sexp_contextp(runner)) { /* ensure the runner exists */
|
||||
if (sexp_envp(runner)) {
|
||||
tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)));
|
||||
tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0);
|
||||
if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) {
|
||||
runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE);
|
||||
sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner;
|
||||
|
|
|
|||
4
sexp.c
4
sexp.c
|
|
@ -103,7 +103,11 @@ static struct sexp_type_struct _sexp_type_specs[] = {
|
|||
{SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, "procedure", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
{SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, "macro", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
{SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
#if SEXP_USE_RENAME_BINDINGS
|
||||
{SEXP_ENV, sexp_offsetof(env, parent), 4, 4, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
#else
|
||||
{SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
#endif
|
||||
{SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, "bytecode", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
{SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, "core-form", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
{SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, "opcode", SEXP_FALSE, SEXP_FALSE, NULL},
|
||||
|
|
|
|||
2
vm.c
2
vm.c
|
|
@ -466,7 +466,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
|
|||
env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
|
||||
sexp_context_env(ctx2) = env;
|
||||
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)));
|
||||
ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls), 0));
|
||||
sexp_push(ctx2, refs, ref);
|
||||
}
|
||||
refs = sexp_reverse(ctx2, refs);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue