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 sexp_maybe_wrap_error utility to pass exceptions from the FFI without raising.

Browse source 
Fixes issue #156.
This commit is contained in:
Alex Shinn 2013-05-29 23:37:30 +09:00
parent dcb8fc292c
commit 9ed486dbe3
3 changed files with 37 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
eval.c
View file

@ -60,6 +60,18 @@ sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to
return SEXP_VOID;
}
sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) {
sexp_gc_var2(tmp, res);
if (sexp_exceptionp(obj)) {
sexp_gc_preserve2(ctx, tmp, res);
tmp = obj;
tmp = sexp_list1(ctx, tmp);
res = sexp_make_trampoline(ctx, SEXP_FALSE, tmp);
sexp_gc_release2(ctx);
return res;
}
return obj;
}
/********************** environment utilities ***************************/

1
include/chibi/eval.h
View file

@ -59,6 +59,7 @@ SEXP_API void sexp_scheme_init (void);
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
SEXP_API sexp sexp_maybe_wrap_error (sexp ctx, sexp obj);
SEXP_API sexp sexp_analyze (sexp context, sexp x);
SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast);
SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params);

25
tests/ffi/ffi-tests.scm
View file

@ -14,7 +14,14 @@
(lambda (out) (write 'decls out) (newline out)))
(let ((res (system
"./chibi-scheme" "tools/chibi-ffi" "-c"
"-f" "-O0 -L. -Iinclude" stub-file)))
"-f" (string-append
"-O0 -L. -Iinclude"
(cond-expand
(boehm-gc
" -DSEXP_USE_BOEHM=1 -I/opt/local/include")
(else
"")))
stub-file)))
(cond
((zero? (cadr res))
(load lib-file)
@ -294,6 +301,22 @@ double circle_area2(struct Circle circ) {
(test 1 (color_red (make_color 1 2 3)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exception wrapping.
(test-ffi
"exceptions"
(begin
(c-declare "
sexp usererror(sexp ctx, sexp self, const char* str) {
return sexp_maybe_wrap_error(ctx, sexp_user_exception(ctx, self, str, SEXP_NULL));
}
")
(define-c sexp usererror
((value ctx sexp) (value self sexp) string)))
(test-assert (exception? (usererror "BOOM!")))
(test-error (usererror 'not-a-string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; More complex return parameters.