diff --git a/eval.c b/eval.c index 3860d91f..9d1d09f2 100644 --- a/eval.c +++ b/eval.c @@ -2544,10 +2544,19 @@ sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version sexp_gc_preserve1(ctx, env); env = sexp_make_primitive_env(ctx, version); if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); + if (sexp_envp(env)) sexp_immutablep(env) = 1; sexp_gc_release1(ctx); return env; } +sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + if (sexp_pointerp(x)) { + sexp_immutablep(x) = 1; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d431bc6a..3ff3b53b 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1756,6 +1756,7 @@ SEXP_API sexp sexp_lookup_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name SEXP_API sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str); SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n); SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port); +SEXP_API sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x); SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_user_exception_ls (sexp ctx, sexp self, const char *msg, int n, ...); diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index b160f299..1432d028 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -364,14 +364,6 @@ sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE; } -sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { - if (sexp_pointerp(x)) { - sexp_immutablep(x) = 1; - return SEXP_TRUE; - } - return SEXP_FALSE; -} - sexp sexp_immutable_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp s) { sexp res; sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, s); @@ -772,7 +764,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op); sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size); sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op); - sexp_define_foreign(ctx, env, "make-immutable!", 1, sexp_make_immutable_op); sexp_define_foreign(ctx, env, "immutable-string", 1, sexp_immutable_string_op); sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE); sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE); diff --git a/lib/meta-7.scm b/lib/meta-7.scm index c9b41e64..077369ca 100644 --- a/lib/meta-7.scm +++ b/lib/meta-7.scm @@ -230,7 +230,7 @@ (warn-undefs env #f) env)))) -(define (environment . ls) +(define (mutable-environment . ls) (let ((env (make-environment))) (for-each (lambda (m) @@ -240,6 +240,11 @@ ls) env)) +(define (environment . ls) + (let ((env (apply mutable-environment ls))) + (make-immutable! env) + env)) + (define (load-module name) (let ((mod (find-module name))) (if (and mod (not (module-env mod))) diff --git a/main.c b/main.c index 482a026f..39109932 100644 --- a/main.c +++ b/main.c @@ -14,11 +14,11 @@ #define sexp_import_prefix "(import (" #define sexp_import_suffix "))" -#define sexp_environment_prefix "(environment '(" +#define sexp_environment_prefix "(mutable-environment '(" #define sexp_environment_suffix "))" #define sexp_trace_prefix "(module-env (load-module '(" #define sexp_trace_suffix ")))" -#define sexp_default_environment "(environment '(scheme small))" +#define sexp_default_environment "(mutable-environment '(scheme small))" #define sexp_advice_environment "(load-module '(chibi repl))" #define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " diff --git a/opcodes.c b/opcodes.c index 552fc698..f0811fa2 100644 --- a/opcodes.c +++ b/opcodes.c @@ -179,6 +179,7 @@ _FN1(_I(SEXP_ENV), _I(SEXP_ENV), "env-parent", 0, sexp_env_parent_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "primitive-environment", 0, sexp_make_primitive_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "make-immutable!", 0, sexp_make_immutable_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "generate", (sexp)"interaction-environment", sexp_generate_op), _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "%load", (sexp)"interaction-environment", sexp_load_op),