From 987b6d98fb5fd519057e647efd704450994b7e5a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 21 May 2011 16:42:02 -0700 Subject: [PATCH] fixing syntactic-closure free-variable references for wrapped expressions (also renaming %env-copy! to %import) --- eval.c | 25 +++++++++++++++++++++++-- include/chibi/eval.h | 4 ++-- lib/config.scm | 2 +- lib/init.scm | 2 +- opcodes.c | 2 +- 5 files changed, 28 insertions(+), 7 deletions(-) diff --git a/eval.c b/eval.c index 66707f0f..46ac5f2b 100755 --- a/eval.c +++ b/eval.c @@ -178,6 +178,27 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { return e; } +sexp sexp_extend_synclo_env (sexp ctx, sexp env) { + sexp e1, e2; + sexp_gc_var1(e); + sexp_gc_preserve1(ctx, e); + e = env; + if (sexp_pairp(sexp_context_fv(ctx))) { + e = sexp_alloc_type(ctx, env, SEXP_ENV); + for (e1=env, e2=NULL; e1; e1=sexp_env_parent(e1)) { + e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e; + sexp_env_bindings(e2) = sexp_env_bindings(e1); + sexp_env_syntactic_p(e2) = 1; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(e2) = sexp_env_renames(e1); +#endif + } + sexp_env_parent(e2) = sexp_context_env(ctx); + } + sexp_gc_release1(ctx); + return e; +} + static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); @@ -871,10 +892,10 @@ static sexp analyze (sexp ctx, sexp object) { res = analyze_var_ref(ctx, x, NULL); } else if (sexp_synclop(x)) { 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(tmp)); + sexp_context_env(tmp) = sexp_extend_synclo_env(tmp, sexp_synclo_env(x)); x = sexp_synclo_expr(x); res = analyze(tmp, x); } else if (sexp_nullp(x)) { @@ -1778,7 +1799,7 @@ sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) #define sexp_same_bindingp(x, y) (sexp_env_value(x) == sexp_env_value(y)) #endif -sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { +sexp sexp_env_import_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { sexp oldname, newname; sexp_gc_var2(value, oldcell); sexp_gc_preserve2(ctx, value, oldcell); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index a716eaa0..105798ae 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -156,7 +156,7 @@ SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env); SEXP_API sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value); -SEXP_API sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_import_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp); SEXP_API sexp sexp_identifier_op(sexp ctx sexp_api_params(self, n), sexp x); SEXP_API sexp sexp_syntactic_closure_expr(sexp ctx sexp_api_params(self, n), sexp x); SEXP_API sexp sexp_identifier_eq_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp c, sexp d); @@ -200,7 +200,7 @@ SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, #define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx sexp_api_pass(NULL, 1), d, a) #define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e) #define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e) -#define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) +#define sexp_env_import(ctx, a, b, c, d) sexp_env_import_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) #define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x) #define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) diff --git a/lib/config.scm b/lib/config.scm index c840fbf4..3a1bb263 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -110,7 +110,7 @@ (lambda (m) (let* ((mod2-name+imports (resolve-import m)) (mod2 (load-module (car mod2-name+imports)))) - (%env-copy! env (module-env mod2) (cdr mod2-name+imports) #t))) + (%import env (module-env mod2) (cdr mod2-name+imports) #t))) (cdr x))))) (module-meta-data mod)) (for-each diff --git a/lib/init.scm b/lib/init.scm index 1f2e4f39..5598f8c5 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -897,7 +897,7 @@ (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) (if (pair? mod+imps) (lp (cdr ls) - (cons `(%env-copy! + (cons `(%import #f (vector-ref (eval '(load-module ',(car mod+imps)) *config-env*) diff --git a/opcodes.c b/opcodes.c index 09f68966..5dfcd77b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -118,7 +118,7 @@ _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op), _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"interaction-environment", sexp_load_op), -_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%import", 0, sexp_env_import_op), _FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), _FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), _FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op),