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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/cfg/builder/builder-tests.factor
View File

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

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

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

4
basis/core-foundation/fsevents/fsevents.factor
View File

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

2
basis/core-foundation/run-loop/run-loop.factor
View File

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

4
basis/db/sqlite/ffi/ffi.factor
View File

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

5
basis/io/backend/unix/multiplexers/run-loop/run-loop.factor
View File

@ -3,13 +3,14 @@
USING: kernel arrays namespaces math accessors alien locals
destructors system threads io.backend.unix.multiplexers
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
TUPLE: run-loop-mx kqueue-mx ;
: file-descriptor-callback ( -- callback )
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
void { CFFileDescriptorRef CFOptionFlags void* }
"cdecl" [
3drop
0 mx get kqueue-mx>> wait-for-events

6
basis/tools/deploy/test/9/9.factor
View File

@ -1,10 +1,10 @@
USING: alien kernel math ;
USING: alien alien.c-types kernel math ;
IN: tools.deploy.test.9
: callback-test ( -- callback )
"int" { "int" } "cdecl" [ 1 + ] alien-callback ;
int { int } "cdecl" [ 1 + ] alien-callback ;
: 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

4
basis/tools/profiler/profiler-tests.factor
View File

@ -21,9 +21,9 @@ words ;
[ ] [ \ + 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 ( -- ) ;

2
basis/ui/backend/windows/windows.factor
View File

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

4
core/alien/alien-docs.factor
View File

@ -79,7 +79,7 @@ HELP: alien-callback-error
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 } }
{ $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
"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
@ -90,7 +90,7 @@ HELP: alien-callback
"A simple example, showing a C function which returns the difference of two given integers:"
{ $code
": 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." } ;

6
extra/benchmark/fib6/fib6.factor
View File

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

2
extra/noise/noise.factor
View File

@ -56,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ;
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ 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' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline