compiler.cfg.builder.alien: fix compilation of callbacks which unconditionally throw...

diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor
index ff7a2cdae21d565d52b4a965406035b5cad508e5..dca9d01fa97154a35bf975789021b67097479d29 100644 (file)
--- a/basis/compiler/cfg/builder/alien/alien.factor
+++ b/basis/compiler/cfg/builder/alien/alien.factor
@@ -182,6 +182,9 @@ M: #alien-assembly emit-node
 : emit-callback-body ( nodes -- )
     [ last #return? t assert= ] [ but-last emit-nodes ] bi ;
 
+: emit-callback-return ( params -- )
+    basic-block get [ callee-return ##callback-outputs ] [ drop ] if ;
+
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
@@ -193,9 +196,9 @@ M: #alien-callback emit-node
             [ params>> callee-parameters ##callback-inputs ]
             [ params>> box-parameters ]
             [ child>> emit-callback-body ]
-            [ params>> callee-return ##callback-outputs ]
+            [ params>> emit-callback-return ]
             [ params>> callback-stack-cleanup ]
         } cleave
 
-        end-word
+        basic-block get [ end-word ] when
     ] with-cfg-builder ;

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 6aa9cd8bcec57fb5e2186fb10c2087fb0775d9e6..feb18e0d7a2537e46c2a3af30f80b3f382eb097a 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -334,6 +334,10 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
 
 ! Test callbacks
+: callback-throws ( -- x )
+    int { } cdecl [ "Hi" throw ] alien-callback ;
+
+[ t ] [ callback-throws alien? ] unit-test
 
 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;