Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-17 18:07:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

more parameter updates

Browse source 
exception handling in (chibi repl) still broken
This commit is contained in:
Alex Shinn 2010-09-26 01:04:55 +09:00
parent 83e91a20c7
commit 5ec136adcb
9 changed files with 79 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
eval.c
View file

@ -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);

1
include/chibi/eval.h
View file

@ -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);

2
include/chibi/sexp.h
View file

@ -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 */

16
lib/chibi/disasm.c
View file

@ -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;
}

35
lib/chibi/repl.scm
View file

@ -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)

4
lib/config.scm
View file

@ -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))))))

4
lib/init.scm
View file

@ -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)

6
tools/genstubs.scm
View file

@ -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))))))

20
vm.c
View file

@ -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;