steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2011-10-02 19:52:02 -07:00
parent 83b11b401f
commit 06218d5d12
2 changed files with 9 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -182,6 +182,9 @@ M: #alien-assembly emit-node
: emit-callback-body ( nodes -- ) : emit-callback-body ( nodes -- )
[ last #return? t assert= ] [ but-last emit-nodes ] bi ; [ 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 M: #alien-callback emit-node
dup params>> xt>> dup dup params>> xt>> dup
[ [
@ -193,9 +196,9 @@ M: #alien-callback emit-node
[ params>> callee-parameters ##callback-inputs ] [ params>> callee-parameters ##callback-inputs ]
[ params>> box-parameters ] [ params>> box-parameters ]
[ child>> emit-callback-body ] [ child>> emit-callback-body ]
[ params>> callee-return ##callback-outputs ] [ params>> emit-callback-return ]
[ params>> callback-stack-cleanup ] [ params>> callback-stack-cleanup ]
} cleave } cleave
end-word basic-block get [ end-word ] when
] with-cfg-builder ; ] with-cfg-builder ;

4
basis/compiler/tests/alien.factor
View File

@ -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 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks ! Test callbacks
: callback-throws ( -- x )
int { } cdecl [ "Hi" throw ] alien-callback ;
[ t ] [ callback-throws alien? ] unit-test
: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ; : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;