From d56d6fd8c6ed8c69b88c4b5ba90b32e98a9ee79a Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 17 Sep 2012 15:03:48 +0900
Subject: [PATCH] Printing error messages when child threads terminate by
 default.

---
 sexp.c |  6 ++++--
 vm.c   | 11 +++++++++++
 2 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/sexp.c b/sexp.c
index b8395b36..a7c9f078 100644
--- a/sexp.c
+++ b/sexp.c
@@ -579,9 +579,10 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
 }
 
 sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out) {
-  sexp ls;
+  sexp_gc_var2(ls, tmp);
+  sexp_gc_preserve2(ctx, ls, tmp);
   if (! sexp_oportp(out))
-    out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
+    out = tmp = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
   sexp_write_string(ctx, "ERROR", out);
   if (sexp_exceptionp(exn)) {
     if (sexp_exception_procedure(exn)) {
@@ -643,6 +644,7 @@ sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp
       sexp_write(ctx, exn, out);
     sexp_write_char(ctx, '\n', out);
   }
+  sexp_gc_release2(ctx);
   return SEXP_VOID;
 }
 
diff --git a/vm.c b/vm.c
index a97d2378..84b229b7 100644
--- a/vm.c
+++ b/vm.c
@@ -2104,6 +2104,17 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
       _ARG1 = SEXP_VOID;
     } else {
       /* don't return from child threads */
+      if (sexp_exceptionp(_ARG1)) {
+        tmp1 = sexp_current_error_port(ctx);
+        sexp_write_string(ctx, "ERROR in child thread: ", tmp1);
+        sexp_write(ctx, ctx, tmp1);
+        sexp_newline(ctx, tmp1);
+        sexp_print_exception(ctx, _ARG1, tmp1);
+      }
+#if SEXP_USE_DEBUG_THREADS
+      fprintf(stderr, "****** schedule: terminating %p (%s)\n",
+              ctx, sexp_thread_debug_name(ctx));
+#endif
       sexp_context_refuel(ctx) = fuel = 0;
       goto loop;
     }