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

Adding an abort facility to exit the vm without any exception handling.

Browse source
This commit is contained in:
Alex Shinn 2015-02-05 22:09:45 +09:00
parent 2922ed591d
commit f54e40547d
4 changed files with 13 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
include/chibi/sexp.h
View file

@ -944,6 +944,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
#define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
#define sexp_trampoline_args(x) sexp_exception_irritants(x)
#define sexp_trampoline_abortp(x) (sexp_exception_message(x) == SEXP_TRAMPOLINE)
#define sexp_cpointer_freep(x) (sexp_freep(x))
#define sexp_cpointer_length(x) (sexp_cpointer_field(x, length))

7
lib/chibi/ast.c
View file

@ -509,6 +509,12 @@ static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
return sexp_make_boolean(unsetenv(sexp_string_data(name)));
}
static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
sexp_exception_message(res) = SEXP_TRAMPOLINE;
return res;
}
#define sexp_define_type(ctx, name, tag) \
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
@ -652,5 +658,6 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv);
sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv);
sexp_define_foreign(ctx, env, "abort", 1, sexp_abort);
return SEXP_VOID;
}

2
lib/chibi/ast.sld
View file

@ -34,7 +34,7 @@
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 thread-list
object-size integer->immediate gc atomically thread-list abort
string-contains string-cursor-copy! errno integer->error-string
flatten-dot update-free-vars! setenv unsetenv safe-setenv)
(import (chibi))

4
vm.c
View file

@ -1064,6 +1064,10 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (sexp_trampolinep(_ARG1)) {
tmp1 = sexp_trampoline_procedure(_ARG1);
tmp2 = sexp_trampoline_args(_ARG1);
if (sexp_trampoline_abortp(_ARG1)) { /* abort - do not catch */
_ARG1 = tmp2;
goto end_loop;
}
top--;
if (sexp_not(tmp1) && sexp_pairp(tmp2)) { /* noop trampoline is */
_PUSH(sexp_car(tmp2)); /* a wrapped exception */