diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index aa176d6c..443342b9 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -39,13 +39,18 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_gc_release2(ctx); } -static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id) { +static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) { sexp cell; sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); cell = sexp_env_cell(env, id, 0); - while ((! cell) && sexp_synclop(id)) { - env = sexp_synclo_env(id); - id = sexp_synclo_expr(id); + if (! cell) { + if (sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + cell = sexp_env_cell(env, id, 0); + if (!cell && createp) + cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL); } return cell ? cell : SEXP_FALSE; } @@ -201,6 +206,55 @@ static sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE; } +static sexp sexp_env_parent_set_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; +} + +static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE; +} + +static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam); + sexp_env_lambda(e) = lam; + return SEXP_VOID; +} + +static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_make_boolean(sexp_env_syntactic_p(e)); +} + +static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + sexp_env_syntactic_p(e) = sexp_truep(synp); + return SEXP_VOID; +} + +static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); + return sexp_env_cell_define(ctx, env, name, value, NULL); +} + +static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { + sexp_gc_var1(tmp); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); + sexp_gc_preserve1(ctx, tmp); + sexp_env_push(ctx, env, tmp, name, value); + sexp_gc_release1(ctx); + return SEXP_VOID; +} + +static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) { + sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c); + return sexp_make_fixnum(sexp_core_code(c)); +} + static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_type_name(t); @@ -305,6 +359,13 @@ static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) { return res; } +static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) { + sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO); + sexp_macro_proc(res) = proc; + sexp_macro_env(res) = env; + return res; +} + static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -314,6 +375,11 @@ static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) return sexp_analyze(ctx2, x); } +static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_extend_env(ctx, env, vars, value); +} + static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp_gc_var2(ls, res); sexp_gc_preserve2(ctx, ls, res); @@ -408,6 +474,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_type(ctx, "Sc", SEXP_SYNCLO); sexp_define_type(ctx, "Context", SEXP_CONTEXT); sexp_define_type(ctx, "Exception", SEXP_EXCEPTION); + sexp_define_type(ctx, "Core", SEXP_CORE); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); @@ -420,6 +487,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE); sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO); @@ -452,6 +520,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL); sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL); sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", NULL); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL); sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL); sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL); sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL); @@ -464,10 +533,11 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op); sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op); sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq); + sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op); sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); - sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); - sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op); + sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class); sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code); @@ -484,7 +554,15 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op); sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op); sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op); - sexp_define_foreign(ctx, env, "environment-parent", 1, sexp_env_parent_op); + sexp_define_foreign(ctx, env, "env-parent", 1, sexp_env_parent_op); + sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op); + sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op); + sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op); + sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op); + sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op); + sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op); + sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op); + 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_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE); sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op); diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 8ab8b1a0..88f8d6ea 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -5,11 +5,12 @@ Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env Number Bignum Flonum Integer Complex Char Boolean Symbol String Byte-Vector Vector Pair File-Descriptor - Context Lam Cnd Set Ref Seq Lit Sc Exception - syntactic-closure? lambda? cnd? set? ref? seq? lit? type? + Context Lam Cnd Set Ref Seq Lit Sc Exception Core + syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core? environment? bytecode? exception? macro? context? file-descriptor? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit + make-macro lambda-name lambda-params lambda-body lambda-defs lambda-locals lambda-flags lambda-free-vars lambda-set-vars lambda-return-type lambda-param-types lambda-source @@ -22,14 +23,15 @@ set-var set-value set-var-set! set-value-set! ref-name ref-cell ref-name-set! ref-cell-set! seq-ls seq-ls-set! lit-value lit-value-set! - exception-kind exception-message exception-irritants + exception-kind exception-message exception-irritants exception-source opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-class opcode-code opcode-data opcode-variadic? macro-procedure macro-env macro-source procedure-code procedure-vars procedure-name procedure-name-set! bytecode-name bytecode-literals bytecode-source port-line port-line-set! - environment-parent + extend-env env-parent env-parent-set! env-lambda env-lambda-set! + env-define! env-push! env-syntactic? env-syntactic?-set! core-code type-name type-cpl type-parent type-slots type-num-slots type-printer object-size integer->immediate gc atomically string-contains integer->error-string diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 1f994966..442e2f9f 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -55,7 +55,7 @@ (let lp ((env env) (res '())) (if (not env) res - (lp (environment-parent env) (append (env-exports env) res))))) + (lp (env-parent env) (append (env-exports env) res))))) (define (string-common-prefix-length strings) (if (null? strings)