From 9ed486dbe3c99a88fc0a30290c580bc12617a43f Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 29 May 2013 23:37:30 +0900
Subject: [PATCH] Adding sexp_maybe_wrap_error utility to pass exceptions from
 the FFI without raising. Fixes issue #156.

---
 eval.c                  | 12 ++++++++++++
 include/chibi/eval.h    |  1 +
 tests/ffi/ffi-tests.scm | 25 ++++++++++++++++++++++++-
 3 files changed, 37 insertions(+), 1 deletion(-)

diff --git a/eval.c b/eval.c
index b9dc37b8..1c8e8118 100644
--- a/eval.c
+++ b/eval.c
@@ -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 ***************************/
 
diff --git a/include/chibi/eval.h b/include/chibi/eval.h
index aa996af7..3364d5c4 100644
--- a/include/chibi/eval.h
+++ b/include/chibi/eval.h
@@ -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);
diff --git a/tests/ffi/ffi-tests.scm b/tests/ffi/ffi-tests.scm
index 7ee3f9e8..fca7521b 100644
--- a/tests/ffi/ffi-tests.scm
+++ b/tests/ffi/ffi-tests.scm
@@ -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.