update a bunch of alien-callbacks and alien-indirects to use c-type words

db4
Joe Groff 2009-10-21 21:10:11 -05:00
parent 7fac3682a6
commit c3b8847936
12 changed files with 47 additions and 46 deletions

View File

@ -68,8 +68,8 @@ IN: compiler.cfg.builder.tests
[ [ dup ] loop ] [ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ] [ [ 2 ] [ 3 throw ] if 4 ]
[ int f "malloc" { int } alien-invoke ] [ int f "malloc" { int } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ] [ int { int } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ] [ int { int } "cdecl" [ ] alien-callback ]
[ swap - + * ] [ swap - + * ]
[ swap slot ] [ swap slot ]
[ blahblah ] [ blahblah ]

View File

@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ;
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result ) : indirect-test-1 ( ptr -- result )
"int" { } "cdecl" alien-indirect ; int { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as { 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- ) : indirect-test-1' ( ptr -- )
"int" { } "cdecl" alien-indirect drop ; int { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as { 1 0 } [ indirect-test-1' ] must-infer-as
@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail [ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result ) : indirect-test-2 ( x y ptr -- result )
"int" { "int" "int" } "cdecl" alien-indirect gc ; int { int int } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as { 3 1 } [ indirect-test-2 ] must-infer-as
@ -115,7 +115,7 @@ FUNCTION: TINY ffi_test_17 int x ;
unit-test unit-test
: indirect-test-3 ( a b c d ptr -- result ) : indirect-test-3 ( a b c d ptr -- result )
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect int { int int int int } "stdcall" alien-indirect
gc ; gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test [ f ] [ "f-stdcall" load-library f = ] unit-test
@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
! Test callbacks ! Test callbacks
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test [ t ] [ callback-1 alien? ] unit-test
: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ; : callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test [ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; : callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test [ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ; : callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [ [ t ] [
namestack* namestack*
@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
] unit-test ] unit-test
: callback-4 ( -- callback ) : callback-4 ( -- callback )
"void" { } "cdecl" [ "Hello world" write ] alien-callback void { } "cdecl" [ "Hello world" write ] alien-callback
gc ; gc ;
[ "Hello world" ] [ [ "Hello world" ] [
@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
] unit-test ] unit-test
: callback-5 ( -- callback ) : callback-5 ( -- callback )
"void" { } "cdecl" [ gc ] alien-callback ; void { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [ [ "testing" ] [
"testing" callback-5 callback_test_1 "testing" callback-5 callback_test_1
] unit-test ] unit-test
: callback-5b ( -- callback ) : callback-5b ( -- callback )
"void" { } "cdecl" [ compact-gc ] alien-callback ; void { } "cdecl" [ compact-gc ] alien-callback ;
[ "testing" ] [ [ "testing" ] [
"testing" callback-5b callback_test_1 "testing" callback-5b callback_test_1
] unit-test ] unit-test
: callback-6 ( -- callback ) : callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback ) : callback-7 ( -- callback )
"void" { } "cdecl" [ 1000000 sleep ] alien-callback ; void { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test [ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback ) : callback-8 ( -- callback )
"void" { } "cdecl" [ void { } "cdecl" [
[ continue ] callcc0 [ continue ] callcc0
] alien-callback ; ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test [ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback ) : callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [ int { int int int } "cdecl" [
+ + 1 + + + 1 +
] alien-callback ; ] alien-callback ;
@ -440,13 +440,13 @@ STRUCT: double-rect
} cleave ; } cleave ;
: double-rect-callback ( -- alien ) : double-rect-callback ( -- alien )
"void" { "void*" "void*" "double-rect" } "cdecl" void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ; [ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' ) : double-rect-test ( arg -- arg' )
f f rot f f rot
double-rect-callback double-rect-callback
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ; "example" get-global ;
[ 1.0 2.0 3.0 4.0 ] [ 1.0 2.0 3.0 4.0 ]
@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
] unit-test ] unit-test
: callback-10 ( -- callback ) : callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl" test_struct_14 { double double } "cdecl"
[ [
test_struct_14 <struct> test_struct_14 <struct>
swap >>x2 swap >>x2
@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
] alien-callback ; ] alien-callback ;
: callback-10-test ( x1 x2 callback -- result ) : callback-10-test ( x1 x2 callback -- result )
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ; test_struct_14 { double double } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test 1.0 2.0 callback-10 callback-10-test
@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
] unit-test ] unit-test
: callback-11 ( -- callback ) : callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl" test-struct-12 { int double } "cdecl"
[ [
test-struct-12 <struct> test-struct-12 <struct>
swap >>x swap >>x
@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
] alien-callback ; ] alien-callback ;
: callback-11-test ( x1 x2 callback -- result ) : callback-11-test ( x1 x2 callback -- result )
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ; test-struct-12 { int double } "cdecl" alien-indirect ;
[ 1 2.0 ] [ [ 1 2.0 ] [
1 2.0 callback-11 callback-11-test 1 2.0 callback-11 callback-11-test
@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback ) : callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl" test_struct_15 { float float } "cdecl"
[ [
test_struct_15 <struct> test_struct_15 <struct>
swap >>y swap >>y
@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
] alien-callback ; ] alien-callback ;
: callback-12-test ( x1 x2 callback -- result ) : callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ; test_struct_15 { float float } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback ) : callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl" test_struct_16 { float int } "cdecl"
[ [
test_struct_16 <struct> test_struct_16 <struct>
swap >>a swap >>a
@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
] alien-callback ; ] alien-callback ;
: callback-13-test ( x1 x2 callback -- result ) : callback-13-test ( x1 x2 callback -- result )
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ; test_struct_16 { float int } "cdecl" alien-indirect ;
[ 1.0 2 ] [ [ 1.0 2 ] [
1.0 2 callback-13 callback-13-test 1.0 2 callback-13 callback-13-test

View File

@ -36,8 +36,8 @@ STRUCT: FSEventStreamContext
{ release void* } { release void* }
{ copyDescription void* } ; { copyDescription void* } ;
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]); ! callback(
TYPEDEF: void* FSEventStreamCallback CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF

View File

@ -115,7 +115,7 @@ PRIVATE>
[ fds>> [ enable-all-callbacks ] each ] bi ; [ fds>> [ enable-all-callbacks ] each ] bi ;
: timer-callback ( -- callback ) : timer-callback ( -- callback )
"void" { "CFRunLoopTimerRef" "void*" } "cdecl" void { CFRunLoopTimerRef void* } "cdecl"
[ 2drop reset-run-loop yield ] alien-callback ; [ 2drop reset-run-loop yield ] alien-callback ;
: init-thread-timer ( -- ) : init-thread-timer ( -- )

View File

@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
TYPEDEF: void sqlite3 TYPEDEF: void* sqlite3*
TYPEDEF: void sqlite3_stmt TYPEDEF: void* sqlite3_stmt*
TYPEDEF: longlong sqlite3_int64 TYPEDEF: longlong sqlite3_int64
TYPEDEF: ulonglong sqlite3_uint64 TYPEDEF: ulonglong sqlite3_uint64

View File

@ -3,13 +3,14 @@
USING: kernel arrays namespaces math accessors alien locals USING: kernel arrays namespaces math accessors alien locals
destructors system threads io.backend.unix.multiplexers destructors system threads io.backend.unix.multiplexers
io.backend.unix.multiplexers.kqueue core-foundation io.backend.unix.multiplexers.kqueue core-foundation
core-foundation.run-loop ; core-foundation.run-loop core-foundation.file-descriptors ;
FROM: alien.c-types => void void* ;
IN: io.backend.unix.multiplexers.run-loop IN: io.backend.unix.multiplexers.run-loop
TUPLE: run-loop-mx kqueue-mx ; TUPLE: run-loop-mx kqueue-mx ;
: file-descriptor-callback ( -- callback ) : file-descriptor-callback ( -- callback )
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } void { CFFileDescriptorRef CFOptionFlags void* }
"cdecl" [ "cdecl" [
3drop 3drop
0 mx get kqueue-mx>> wait-for-events 0 mx get kqueue-mx>> wait-for-events

View File

@ -1,10 +1,10 @@
USING: alien kernel math ; USING: alien alien.c-types kernel math ;
IN: tools.deploy.test.9 IN: tools.deploy.test.9
: callback-test ( -- callback ) : callback-test ( -- callback )
"int" { "int" } "cdecl" [ 1 + ] alien-callback ; int { int } "cdecl" [ 1 + ] alien-callback ;
: indirect-test ( -- ) : indirect-test ( -- )
10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ; 10 callback-test int { int } "cdecl" alien-indirect 11 assert= ;
MAIN: indirect-test MAIN: indirect-test

View File

@ -21,9 +21,9 @@ words ;
[ ] [ \ + usage-profile. ] unit-test [ ] [ \ + usage-profile. ] unit-test
: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; : callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ;
: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ; : indirect-test ( callback -- ) void { } "cdecl" alien-indirect ;
: foobar ( -- ) ; : foobar ( -- ) ;

View File

@ -596,7 +596,7 @@ SYMBOL: trace-messages?
! return 0 if you handle the message, else just let DefWindowProc return its val ! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object ) : ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [ uint { void* uint long long } "stdcall" [
pick pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if

View File

@ -79,7 +79,7 @@ HELP: alien-callback-error
HELP: alien-callback HELP: alien-callback
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } } { $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
{ $description { $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned." "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl $nl
"When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled." "When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
$nl $nl
@ -90,7 +90,7 @@ HELP: alien-callback
"A simple example, showing a C function which returns the difference of two given integers:" "A simple example, showing a C function which returns the difference of two given integers:"
{ $code { $code
": difference-callback ( -- alien )" ": difference-callback ( -- alien )"
" \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;" " int { int int } \"cdecl\" [ - ] alien-callback ;"
} }
} }
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ; { $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;

View File

@ -1,13 +1,13 @@
USING: math kernel alien ; USING: math kernel alien alien.c-types ;
IN: benchmark.fib6 IN: benchmark.fib6
: fib ( x -- y ) : fib ( x -- y )
"int" { "int" } "cdecl" [ int { int } "cdecl" [
dup 1 <= [ drop 1 ] [ dup 1 <= [ drop 1 ] [
1 - dup fib swap 1 - fib + 1 - dup fib swap 1 - fib +
] if ] if
] alien-callback ] alien-callback
"int" { "int" } "cdecl" alien-indirect ; int { int } "cdecl" alien-indirect ;
: fib-main ( -- ) 32 fib drop ; : fib-main ( -- ) 32 fib drop ;

View File

@ -56,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ;
dup { [ byte-array? ] [ length 512 >= ] } 1&& dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ; [ invalid-perlin-noise-table ] unless ;
! XXX doesn't work for NaNs or floats > 2^31 ! XXX doesn't work when v is nan or |v| >= 2^31
: floor-vector ( v -- v' ) : floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ] [ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline [ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline