Fix infinite loop and empty-dlist error when an error is thrown from a callback running in a thread other than the initial thread. This addresses part of issue #92

basis/compiler/tests/callback-error.factor

@@ -0,0 +1,43 @@
+USING: accessors io io.encodings.ascii io.launcher kernel make
+sequences system tools.test ;
+IN: compiler.tests.callback-error
+
+: run-vm-with-script ( string -- lines )
+    [ <process> ] dip
+        [ vm , , ] { } make >>command
+        +closed+ >>stdin
+        +stdout+ >>stderr
+    ascii <process-reader> stream-lines ;
+
+! Callback error from initial thread
+[ t ] [
+    """-e=USING: alien alien.c-types alien.syntax kernel ;
+    IN: scratchpad
+    
+    : callback-death ( -- callback )
+        void { } cdecl [ "Error!" throw ] alien-callback ;
+    
+    : callback-invoke ( callback -- )
+        void { } cdecl alien-indirect ;
+    
+    callback-death callback-invoke"""
+    run-vm-with-script
+    "\"Error!\"" swap member?
+] unit-test
+
+! Callback error from another thread
+[ t ] [
+    """-e=USING: alien alien.c-types alien.syntax kernel threads ;
+    IN: scratchpad
+    
+    : callback-death ( -- callback )
+        void { } cdecl [ "Error!" throw ] alien-callback ;
+    
+    : callback-invoke ( callback -- )
+        void { } cdecl alien-indirect ;
+    
+    [ callback-death callback-invoke ] in-thread
+    stop"""
+    run-vm-with-script
+    "\"Error!\"" swap member?
+] unit-test

basis/debugger/threads/threads.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors debugger continuations threads threads.private
+USING: accessors alien debugger continuations threads
-io io.styles prettyprint kernel math.parser namespaces make ;
+threads.private io io.styles prettyprint kernel make math.parser
+namespaces ;
 IN: debugger.threads
 
 : error-in-thread. ( thread -- )
@@ -12,17 +13,21 @@ IN: debugger.threads
         ", " % dup quot>> unparse-short % ")" %
     ] "" make swap write-object ":" print ;
 
-M: thread error-in-thread ( error thread -- )
+: call-thread-error-handler? ( thread -- ? )
-    initial-thread get-global eq? [
+    initial-thread get-global eq?
-        die drop
+    in-callback?
-    ] [
+    or not ;
-        global [
-            error-thread get-global error-in-thread. nl
-            print-error nl
-            :c
-            flush
-        ] bind
-    ] if ;
 
-[ self error-in-thread stop ]
+M: thread error-in-thread ( error thread -- )
-thread-error-hook set-global
+    global [
+        error-in-thread. nl
+        print-error nl
+        :c
+        flush
+    ] bind ;
+
+[
+    dup call-thread-error-handler?
+    [ self error-in-thread stop ]
+    [ [ die ] call( error thread -- * ) ] if
+] thread-error-hook set-global

core/alien/alien.factor

@@ -103,6 +103,7 @@ SYMBOL: callbacks
 
 ! Used by compiler.codegen to wrap callback bodies
 : do-callback ( callback-quot wait-quot: ( callback -- ) -- )
+    t 3 set-context-object
     init-namespaces
     init-catchstack
     current-callback
@@ -117,6 +118,8 @@ TUPLE: expiry-check object alien ;
 
 PRIVATE>
 
+: in-callback? ( -- ? ) 3 context-object ;
+
 : initialize-alien ( symbol quot -- )
     swap dup get-global dup recompute-value?
     [ drop [ call dup 31337 <alien> expiry-check boa ] dip set-global ]

vm/contexts.hpp

@@ -7,6 +7,7 @@ enum context_object {
 	OBJ_NAMESTACK,
 	OBJ_CATCHSTACK,
 	OBJ_CONTEXT,
+	OBJ_IN_CALLBACK_P,
 };
 
 static const cell stack_reserved = 1024;