version 1.1, 2005/08/21 22:09:14
|
version 1.9, 2005/12/11 20:10:01
|
Line 104 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 104 Create argptr maxargs 0 [DO] argbuf [I]
|
\ "forward" when revarg is on |
\ "forward" when revarg is on |
|
|
\ : >c+ ( char buf -- buf' ) tuck c! cell+ cell+ ; |
\ : >c+ ( char buf -- buf' ) tuck c! cell+ cell+ ; |
: >i+ ( n buf -- buf' ) tuck ! cell+ cell+ ; |
: >i+ ( n buf -- buf' ) tuck l! cell+ cell+ ; |
: >p+ ( addr buf -- buf' ) tuck ! cell+ cell+ ; |
: >p+ ( addr buf -- buf' ) tuck ! cell+ cell+ ; |
: >d+ ( d buf -- buf' ) dup >r ffi-2! r> cell+ cell+ ; |
: >d+ ( d buf -- buf' ) dup >r ffi-2! r> cell+ cell+ ; |
: >sf+ ( r buf -- buf' ) dup sf! cell+ cell+ ; |
: >sf+ ( r buf -- buf' ) dup sf! cell+ cell+ ; |
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 l! ; |
: >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 l@ ; |
: i>x ( -- n ) retbuf @ ; |
: is>x ( -- n ) retbuf sl@ ; |
: 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 130 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 148 Variable args args off
|
Line 148 Variable args args off
|
revarg @ IF drop 0 ELSE 2* cells THEN argbuf + |
revarg @ IF drop 0 ELSE 2* cells THEN argbuf + |
postpone Literal ; |
postpone Literal ; |
|
|
|
Variable ind-call ind-call off |
|
: fptr: ind-call on Create here thisproc ! |
|
0 , 0 , 0 , 0 also c-decl DOES> cell+ dup cell+ cell+ >r ! ; |
|
|
: ffi-call, ( -- lit-cif ) |
: ffi-call, ( -- lit-cif ) |
postpone drop postpone argptr postpone retbuf |
postpone drop postpone argptr postpone retbuf |
thisproc @ cell+ postpone literal postpone @ |
thisproc @ cell+ postpone literal postpone @ |
Line 160 Variable args args off
|
Line 164 Variable args args off
|
: cif@ ( -- addr u ) |
: cif@ ( -- addr u ) |
cifbuf cell+ cifbuf @ over - ; |
cifbuf cell+ cifbuf @ over - ; |
|
|
: make-cif ( rtype -- addr ) cif, |
: create-cif ( rtype -- addr ) cif, |
cif@ cifs search-wordlist |
cif@ cifs search-wordlist |
IF execute EXIT THEN |
IF execute EXIT THEN |
get-current >r cifs set-current |
get-current >r cifs set-current |
cif@ nextname Create here >r |
cif@ nextname Create here >r |
cif@ 1- bounds ?DO I c@ ffi-type , LOOP |
cif@ 1- bounds ?DO I c@ ffi-type , LOOP r> |
r> cif@ 1- tuck + c@ ffi-type here dup >r 0 ffi-size allot |
r> set-current ; |
ffi-prep-cif throw |
|
r> r> set-current ; |
: make-cif ( rtype -- addr ) create-cif |
|
cif@ 1- tuck + c@ ffi-type here 0 ffi-size allot |
|
dup >r ffi-prep-cif throw r> ; |
|
|
: 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 185 Variable args args off
|
Line 191 Variable args args off
|
|
|
: rettype ( endxt n "name" -- ) |
: rettype ( endxt n "name" -- ) |
Create 2, |
Create 2, |
DOES> 2@ args @ decl, symbol, previous revarg off args off ; |
DOES> 2@ args @ decl, ind-call @ 0= IF symbol, THEN |
|
previous revarg off args off ind-call off ; |
|
|
also c-decl definitions |
also c-decl definitions |
|
|
Line 198 also c-decl definitions
|
Line 205 also c-decl definitions
|
' >df+ ' >df- &10 argtype df |
' >df+ ' >df- &10 argtype df |
|
|
' noop 0 rettype (void) |
' noop 0 rettype (void) |
' i>x 6 rettype (int) |
' is>x 6 rettype (int) |
|
' i>x 6 rettype (uint) |
' p>x &12 rettype (ptr) |
' p>x &12 rettype (ptr) |
' d>x 8 rettype (llong) |
' d>x 8 rettype (llong) |
' sf>x 9 rettype (sf) |
' sf>x 9 rettype (sf) |
' df>x &10 rettype (fp) |
' df>x &10 rettype (fp) |
|
|
|
: (addr) thisproc @ cell+ postpone Literal postpone @ postpone EXIT |
|
drop symbol, previous revarg off args off ; |
|
|
previous definitions |
previous definitions |
|
|
\ legacy support for old library interfaces |
\ legacy support for old library interfaces |
Line 227 previous
|
Line 238 previous
|
|
|
\ callback stuff |
\ callback stuff |
|
|
0 [IF] |
|
Variable callbacks |
Variable callbacks |
\G link between callbacks |
\G link between callbacks |
|
|
|
Variable rtype |
|
|
|
: alloc-callback ( ip -- addr ) |
|
rtype @ make-cif here 1 ffi-size allot |
|
dup >r 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 ! |
0 Value -1 cells allot |
|
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@ cell+ cell+ alloc-callback r> ! ; |
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 278 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] |
|