version 1.3, 2005/11/27 22:47:18
|
version 1.10, 2005/12/11 21:58:20
|
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 |
|
|
: >i- ( n buf -- buf' ) 2 cells - tuck ffi-i! ; |
: >i- ( n buf -- buf' ) 2 cells - tuck l! ; |
: >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 120 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 120 Create argptr maxargs 0 [DO] argbuf [I]
|
|
|
\ return value |
\ return value |
|
|
: i>x ( -- n ) retbuf ffi-i@ ; |
: i>x ( -- n ) retbuf l@ ; |
|
: 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 147 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 159 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 } cifreset |
start, { retxt rtype } cifreset |
Line 184 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 197 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 |
: (addr) thisproc @ cell+ postpone Literal postpone @ postpone EXIT |
symbol, previous revarg off args off ; |
drop symbol, previous revarg off args off ; |
|
|
previous definitions |
previous definitions |
|
|
Line 234 Variable callbacks
|
Line 243 Variable callbacks
|
|
|
Variable rtype |
Variable rtype |
|
|
: alloc-callback ( -- addr ) |
: alloc-callback ( ip -- addr ) |
rtype @ cif, |
rtype @ make-cif here 1 ffi-size allot |
here >r |
dup >r ffi-prep-closure throw 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 cifreset |
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 arg1 .. argn -- ) |
: callback; ( 0 arg1 .. argn -- ) |
BEGIN over WHILE compile, REPEAT |
BEGIN over WHILE compile, REPEAT |