version 1.1, 2005/08/21 22:09:14
|
version 1.2, 2005/11/20 23:15:42
|
Line 112 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 112 Create argptr maxargs 0 [DO] argbuf [I]
|
|
|
\ "backward" when revarg is off |
\ "backward" when revarg is off |
|
|
\ : >c- ( char buf -- buf' ) tuck c! 2 cells - ; |
: >i- ( n buf -- buf' ) 2 cells - tuck ffi-i! ; |
: >i- ( n buf -- buf' ) 2 cells - tuck ! ; |
|
: >p- ( addr buf -- buf' ) 2 cells - tuck ! ; |
: >p- ( addr buf -- buf' ) 2 cells - tuck ! ; |
: >d- ( d buf -- buf' ) 2 cells - dup >r ffi-2! r> ; |
: >d- ( d buf -- buf' ) 2 cells - dup >r ffi-2! r> ; |
: >sf- ( r buf -- buf' ) 2 cells - dup sf! ; |
: >sf- ( r buf -- buf' ) 2 cells - dup sf! ; |
Line 121 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 120 Create argptr maxargs 0 [DO] argbuf [I]
|
|
|
\ return value |
\ return value |
|
|
\ : c> ( -- c ) retbuf c@ ; |
: i>x ( -- n ) retbuf ffi-i@ ; |
: i>x ( -- n ) retbuf @ ; |
|
: p>x ( -- addr ) retbuf @ ; |
: p>x ( -- addr ) retbuf @ ; |
: d>x ( -- d ) retbuf ffi-2@ ; |
: d>x ( -- d ) retbuf ffi-2@ ; |
: sf>x ( -- r ) retbuf sf@ ; |
: sf>x ( -- r ) retbuf sf@ ; |
Line 131 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 129 Create argptr maxargs 0 [DO] argbuf [I]
|
wordlist constant cifs |
wordlist constant cifs |
|
|
Variable cifbuf $40 allot \ maximum: 64 parameters |
Variable cifbuf $40 allot \ maximum: 64 parameters |
cifbuf cell+ cifbuf ! |
: cifreset cifbuf cell+ cifbuf ! ; |
|
cifreset |
Variable args args off |
Variable args args off |
|
|
: argtype ( bkxt fwxt type "name" -- ) |
: argtype ( bkxt fwxt type "name" -- ) |
Line 171 Variable args args off
|
Line 170 Variable args args off
|
r> r> set-current ; |
r> r> set-current ; |
|
|
: decl, ( 0 arg1 .. argn call rtype start -- ) |
: decl, ( 0 arg1 .. argn call rtype start -- ) |
start, { retxt rtype } |
start, { retxt rtype } cifreset |
revdec @ IF 0 >r |
revdec @ IF 0 >r |
BEGIN dup WHILE >r REPEAT |
BEGIN dup WHILE >r REPEAT |
BEGIN r> dup WHILE arg@ arg, REPEAT |
BEGIN r> dup WHILE arg@ arg, REPEAT |
Line 227 previous
|
Line 226 previous
|
|
|
\ callback stuff |
\ callback stuff |
|
|
0 [IF] |
|
Variable callbacks |
Variable callbacks |
\G link between callbacks |
\G link between callbacks |
|
|
|
Variable rtype |
|
|
|
: alloc-callback ( -- addr ) |
|
rtype @ cif, |
|
here >r |
|
cif@ 1- bounds ?DO I c@ ffi-type , LOOP |
|
r> cif@ 1- tuck + c@ ffi-type here dup >r 1 ffi-size allot |
|
ffi-prep-closure throw r> ; |
|
|
: callback ( -- ) |
: callback ( -- ) |
Create 0 ] postpone >r also cb-decl |
Create 0 ] postpone >r also cb-decl cifreset |
DOES> |
DOES> |
Create here >r 0 , callbacks @ A, r@ callbacks ! |
Create here >r 0 , callbacks @ A, r@ callbacks ! |
swap postpone Literal postpone call , postpone EXIT |
swap postpone Literal postpone call , postpone EXIT |
r> dup cell+ cell+ alloc-callback swap ! |
r> dup cell+ cell+ alloc-callback swap ! |
DOES> @ ; |
DOES> @ ; |
|
|
: callback; ( 0 xt1 .. xtn -- ) |
: callback; ( 0 arg1 .. argn -- ) |
BEGIN over WHILE compile, REPEAT |
BEGIN over WHILE compile, REPEAT |
postpone r> postpone execute compile, drop |
postpone r> postpone execute compile, drop |
postpone EXIT postpone [ previous ; immediate |
postpone EXIT postpone [ previous ; immediate |
|
|
: va-ret ( xt xt -- ) |
: rettype' ( xt n -- ) |
Create A, A, immediate |
Create , A, immediate |
DOES> 2@ compile, ; |
DOES> 2@ rtype ! ; |
|
: argtype' ( xt n -- ) |
|
Create , A, immediate |
|
DOES> 2@ cif, ; |
|
|
: init-callbacks ( -- ) |
: init-callbacks ( -- ) |
defers 'cold callbacks cell - |
defers 'cold callbacks cell - |
Line 259 also cb-decl definitions
|
Line 269 also cb-decl definitions
|
|
|
\ arguments |
\ arguments |
|
|
' va-arg-int Alias int |
' ffi-arg-int 6 argtype' int |
' va-arg-float Alias sf |
' ffi-arg-float 9 argtype' sf |
' va-arg-double Alias df |
' ffi-arg-double &10 argtype' df |
' va-arg-longlong Alias llong |
' ffi-arg-longlong 8 argtype' llong |
' va-arg-ptr Alias ptr |
' ffi-arg-ptr &12 argtype' ptr |
|
|
' va-return-void ' va-start-void va-ret (void) |
' ffi-ret-void 0 rettype' (void) |
' va-return-int ' va-start-int va-ret (int) |
' ffi-ret-int 6 rettype' (int) |
' va-return-float ' va-start-float va-ret (sf) |
' ffi-ret-float 9 rettype' (sf) |
' va-return-double ' va-start-double va-ret (fp) |
' ffi-ret-double &10 rettype' (fp) |
' va-return-longlong ' va-start-longlong va-ret (llong) |
' ffi-ret-longlong 8 rettype' (llong) |
' va-return-ptr ' va-start-ptr va-ret (ptr) |
' ffi-ret-ptr &12 rettype' (ptr) |
|
|
previous definitions |
previous definitions |
|
|
[THEN] |
|
|
|
\ testing stuff |
|
|
|
[ifdef] testing |
|
|
|
library libc libc.so.6 |
|
|
|
libc sleep int (int) sleep |
|
libc open int int ptr (int) open |
|
libc lseek int llong int (llong) lseek64 |
|
libc read int ptr int (int) read |
|
libc close int (int) close |
|
|
|
library libm libm.so.6 |
|
|
|
libm fmodf sf sf (sf) fmodf |
|
libm fmod df df (fp) fmod |
|
|
|
\ example for a windows callback |
|
|
|
callback wincall (int) int int int int callback; |
|
|
|
:noname ( a b c d -- e ) 2drop 2drop 0 ; wincall do_timer |
|
|
|
\ test a callback |
|
|
|
callback 2:1 (int) int int callback; |
|
|
|
: cb-test ( a b -- c ) |
|
cr ." Testing callback" |
|
cr ." arguments: " .s |
|
cr ." result " + .s cr ; |
|
' cb-test 2:1 c_plus |
|
|
|
: test c_plus av-start-int >r >r av-int-r av-int-r av-call-int ; |
|
|
|
\ 3 4 test |
|
|
|
\ bigFORTH legacy library test |
|
|
|
library libX11 libX11.so.6 |
|
|
|
legacy on |
|
|
|
1 libX11 XOpenDisplay XOpenDisplay ( name -- dpy ) |
|
5 libX11 XInternAtoms XInternAtoms ( atoms flag count names dpy -- status ) |
|
|
|
legacy off |
|
|
|
[then] |
|