~ chicken-core (chicken-5) 1186f2232a686f0bfd92f7be3de9784cf4c6f2d3

commit 1186f2232a686f0bfd92f7be3de9784cf4c6f2d3
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 13 06:25:01 2010 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 13 06:25:01 2010 -0400

    check callbacks for returning twice

diff --git a/distribution/manifest b/distribution/manifest
index 158c4385..6c2ceb82 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -160,6 +160,7 @@ tests/private-repository-test.scm
 tests/records-and-setters-test.scm
 tests/dwindtst.scm
 tests/dwindtst.expected
+tests/callback-tests.scm
 tweaks.scm
 utils.scm
 apply-hack.x86.S
diff --git a/runtime.c b/runtime.c
index 730fb6f9..688ca5ff 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1737,7 +1737,7 @@ C_word C_fcall C_callback(C_word closure, int argc)
   jmp_buf prev;
   C_word 
     *a = C_alloc(2),
-    k = C_closure(&a, 1, (C_word)callback_return_continuation);
+    k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE);
   int old = chicken_is_running;
 
   if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
@@ -1800,8 +1800,12 @@ C_word C_fcall C_callback_wrapper(void *proc, int argc)
 
 void C_ccall callback_return_continuation(C_word c, C_word self, C_word r)
 {
+  if(C_block_item(self, 1) == C_SCHEME_TRUE)
+    panic(C_text("callback returned twice"));
+
   assert(callback_returned_flag == 0);
   callback_returned_flag = 1;
+  C_set_block_item(self, 1, C_SCHEME_TRUE);
   C_save(r);
   C_reclaim(NULL, NULL);
 }
diff --git a/tests/callback-tests.scm b/tests/callback-tests.scm
new file mode 100644
index 00000000..afac01ee
--- /dev/null
+++ b/tests/callback-tests.scm
@@ -0,0 +1,20 @@
+;;;; callback-tests.scm
+
+
+(define k1)
+
+(define-external (foo) void
+  (call/cc
+   (lambda (k) (set! k1 k)))
+  (print "hi!"))
+
+#>
+extern void foo();
+static void bar() { foo(); }
+<#
+
+(print "callbacks ...")
+((foreign-safe-lambda void "bar"))
+
+(when (member "twice" (command-line-arguments))
+  (k1 #f))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 804edb17..e2c2eab6 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -73,6 +73,17 @@ fi
 
 diff -bu scrutiny.out scrutiny.expected
 
+echo "======================================== callback tests ..."
+$compile callback-tests.scm
+./a.out
+
+if ./a.out twice; then
+    echo "double-return from callback didn't fail"
+    exit 1
+else
+    echo "double-return from callback failed as it should."
+fi
+
 echo "======================================== runtime tests ..."
 $interpret -s apply-test.scm
 $compile test-gc-hooks.scm
@@ -126,7 +137,7 @@ $compile compiler-syntax-tests.scm
 ./a.out
 
 echo "======================================== import tests ..."
-$interpret import-tests.scm
+$interpret -bnq import-tests.scm
 
 echo "======================================== import library tests ..."
 rm -f ../foo.import.* foo.import.*