From 5ec136adcbfe5be684fc8895dc8ed3df92689348 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 26 Sep 2010 01:04:55 +0900 Subject: [PATCH] more parameter updates exception handling in (chibi repl) still broken --- eval.c | 32 ++++++++++++++++++++++---------- include/chibi/eval.h | 1 + include/chibi/sexp.h | 2 +- lib/chibi/disasm.c | 16 +++++++++++++++- lib/chibi/repl.scm | 35 ++++++++++++++++++++--------------- lib/config.scm | 4 ++-- lib/init.scm | 4 +--- tools/genstubs.scm | 6 +++--- vm.c | 20 ++++++++++++++------ 9 files changed, 79 insertions(+), 41 deletions(-) diff --git a/eval.c b/eval.c index add0196e..8a7c9b3d 100644 --- a/eval.c +++ b/eval.c @@ -324,9 +324,6 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var3(tmp, vec, ctx2); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve3(ctx, tmp, vec, ctx2); - vec = sexp_intern(ctx, "*current-exception-handler*", -1); - sexp_global(ctx, SEXP_G_ERR_HANDLER) - = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); #if ! SEXP_USE_NATIVE_X86 emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); @@ -372,6 +369,7 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); if (! ctx) sexp_init_eval_context_globals(res); if (ctx) { + sexp_context_params(res) = sexp_context_params(ctx); sexp_context_tracep(res) = sexp_context_tracep(ctx); sexp_gc_release1(ctx); } @@ -1443,8 +1441,9 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); tmp = sexp_intern(ctx, param, -1); - tmp = sexp_env_cell(env, tmp); - res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_opcodep(tmp)) + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); sexp_gc_release1(ctx); return res; } @@ -1589,6 +1588,17 @@ sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, return SEXP_VOID; } +sexp sexp_parameter_ref (sexp ctx, sexp param) { +#if SEXP_USE_GREEN_THREADS + sexp ls; + for (ls=sexp_context_params(ctx); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == param) + return sexp_cdar(ls); +#endif + return sexp_opcodep(param) && sexp_opcode_data(param) && sexp_pairp(sexp_opcode_data(param)) + ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE; +} + static void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { sexp param = sexp_env_ref(env, name, SEXP_FALSE); if (sexp_opcodep(param)) { @@ -1650,6 +1660,8 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); #endif + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_ref(e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE); /* load init.scm */ tmp = sexp_load_module_file(ctx, sexp_init_file, e); /* load and bind config env */ @@ -1755,20 +1767,20 @@ sexp sexp_compile (sexp ctx, sexp x) { sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { sexp_sint_t top; sexp ctx2; - sexp_gc_var2(res, err_handler); + sexp_gc_var2(res, params); if (! env) env = sexp_context_env(ctx); sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); - sexp_gc_preserve2(ctx, res, err_handler); + sexp_gc_preserve2(ctx, res, params); top = sexp_context_top(ctx); - err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); - sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + params = sexp_context_params(ctx); + sexp_context_params(ctx) = SEXP_NULL; ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); sexp_context_child(ctx) = ctx2; res = sexp_compile(ctx2, obj); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); sexp_context_child(ctx) = SEXP_FALSE; - sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_params(ctx) = params; sexp_context_top(ctx) = top; sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); sexp_gc_release2(ctx); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 6c30ab77..daa7aea2 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -158,6 +158,7 @@ SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); 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); SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d8c4afd0..74ce75c6 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1058,7 +1058,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) #endif -#define sexp_current_error_port(ctx) sexp_env_global_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(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))) /* simplify primitive API interface */ diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 4f9c8493..b8f7bdbc 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -14,6 +14,12 @@ static void sexp_write_pointer (sexp ctx, void *p, sexp out) { sexp_write_string(ctx, buf, out); } +static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) { + char buf[32]; + sprintf(buf, "%ld", n); + sexp_write_string(ctx, buf, out); +} + static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp tmp=NULL; unsigned char *ip, opcode, i; @@ -64,6 +70,9 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_JUMP: case SEXP_OP_JUMP_UNLESS: case SEXP_OP_TYPEP: + sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); + ip += sizeof(sexp); + break; case SEXP_OP_FCALL0: case SEXP_OP_FCALL1: case SEXP_OP_FCALL2: @@ -79,6 +88,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { break; case SEXP_OP_GLOBAL_REF: case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_PARAMETER_REF: case SEXP_OP_TAIL_CALL: case SEXP_OP_CALL: case SEXP_OP_PUSH: @@ -86,6 +96,10 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) && sexp_pairp(tmp)) tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PARAMETER_REF) + && sexp_opcodep(tmp) && sexp_opcode_data(tmp) + && sexp_pairp(sexp_opcode_data(tmp))) + tmp = sexp_car(sexp_opcode_data(tmp)); else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) sexp_write_char(ctx, '\'', out); sexp_write(ctx, tmp, out); @@ -106,6 +120,6 @@ static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { } sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { - sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "current-output-port"); return SEXP_VOID; } diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index d4ae19c9..634271e4 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -5,41 +5,46 @@ (define-syntax handle-exceptions (syntax-rules () - ((handle-exceptions exn handler expr) + ((handle-exceptions exn handle-expr expr) (call-with-current-continuation (lambda (return) - (with-exception-handler (lambda (exn) (return handler)) - (lambda () expr))))))) + (with-exception-handler + (lambda (exn) (return handle-expr)) + (lambda () expr))))))) (define (with-signal-handler sig handler thunk) (let ((old-handler #f)) (dynamic-wind - (lambda () (set! old-handler (set-signal-action! sig handler))) - thunk - (lambda () (set-signal-action! sig old-handler))))) + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) (define (run-repl module env . o) (let ((history (make-history))) (let lp ((module module) (env env)) - (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ") - 'history: history))) + (let ((line + (edit-line + (string-append (if module (symbol->string module) "") "> ") + 'history: history))) (cond ((or (not line) (eof-object? line))) ((equal? line "") (lp module env)) (else (history-commit! history line) (handle-exceptions - exn (print-exception exn (current-error-port)) + exn + (print-exception exn (current-error-port)) (let* ((expr (call-with-input-string line read/ss)) - (thread (make-thread (lambda () - (let ((res (eval expr env))) - (if (not (eq? res (if #f #f))) - (write/ss res)) - (newline)))))) + (thread (make-thread + (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write/ss res)) + (newline)))))) (with-signal-handler signal/interrupt (lambda (n) (thread-terminate! thread)) - (lambda () (thread-start! thread) (thread-join! thread))))) + (lambda () (thread-join! (thread-start! thread)))))) (lp module env))))))) (define (repl) diff --git a/lib/config.scm b/lib/config.scm index 55a4e1e0..5542f1dc 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -171,9 +171,9 @@ '((include "init.scm")))) (cons '(config) (make-module #f (current-environment) '())) (cons '(srfi 0) (make-module (list 'cond-expand) - (interaction-environment) + (current-environment) (list (list 'export 'cond-expand)))) (cons '(srfi 46) (make-module (list 'syntax-rules) - (interaction-environment) + (current-environment) (list (list 'export 'syntax-rules)))))) diff --git a/lib/init.scm b/lib/init.scm index c8a807e7..0df5cb0a 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -321,9 +321,7 @@ (letrec ((orig-handler (current-exception-handler)) (self (lambda (exn) (current-exception-handler orig-handler) - (let ((res (handler exn))) - (current-exception-handler self) - res)))) + (handler exn)))) (current-exception-handler self) (let ((res (thunk))) (current-exception-handler orig-handler) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 6e95b2a5..3a932523 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1024,11 +1024,11 @@ (let ((value (type-value x))) (cond ((equal? value '(current-input-port)) - (cat "\"*current-input-port*\"")) + (cat "\"current-input-port\"")) ((equal? value '(current-output-port)) - (cat "\"*current-output-port*\"")) + (cat "\"current-output-port\"")) ((equal? value '(current-error-port)) - (cat "\"*current-error-port*\"")) + (cat "\"current-error-port\"")) (else (c->scheme-converter x value)))))) diff --git a/vm.c b/vm.c index 27f5916d..3d8a8267 100644 --- a/vm.c +++ b/vm.c @@ -205,15 +205,19 @@ static void generate_opcode_app (sexp ctx, sexp app) { if (sexp_opcode_inverse(op)) { inv_default = 1; } else { - emit_push(ctx, sexp_opcode_data(op)); if (sexp_opcode_opt_param_p(op)) { #if SEXP_USE_GREEN_THREADS emit(ctx, SEXP_OP_PARAMETER_REF); emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); - sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), sexp_opcode_data(op)); +#else + emit_push(ctx, sexp_opcode_data(op)); #endif emit(ctx, SEXP_OP_CDR); + } else { + emit_push(ctx, sexp_opcode_data(op)); } + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), + sexp_opcode_data(op)); sexp_context_depth(ctx)++; num_args++; } @@ -584,8 +588,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { #if SEXP_USE_DEBUG_VM if (sexp_context_tracep(ctx)) { sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE); - fprintf(stderr, "%s ip: %p stack: %p top: %d fp: %d\n", (*ip<=SEXP_OP_NUM_OPCODES) ? - reverse_opcode_names[*ip] : "UNKNOWN", ip, stack, top, fp); + fprintf(stderr, "%s %s ip: %p stack: %p top: %ld fp: %ld (%ld)\n", + (*ip<=SEXP_OP_NUM_OPCODES) ? reverse_opcode_names[*ip] : "UNKNOWN", + (SEXP_OP_FCALL0 <= *ip && *ip <= SEXP_OP_FCALL4 + ? sexp_opcode_name(((sexp*)(ip+1))[0]) : ""), + ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1)); } #endif switch (*ip++) { @@ -595,9 +602,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { if (! sexp_exception_procedure(_ARG1)) sexp_exception_procedure(_ARG1) = self; case SEXP_OP_RAISE: - tmp1 = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER)); sexp_context_last_fp(ctx) = fp; - if (! sexp_procedurep(tmp1)) goto end_loop; + if (! sexp_procedurep(tmp1)) + goto end_loop; stack[top] = SEXP_ONE; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self;