[BACK]Return to libffi.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/libffi.fs between versions 1.1 and 1.8

version 1.1, 2005/08/21 22:09:14 version 1.8, 2005/12/11 20:08:09
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
   : ind:  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]      
Removed from v.1.1  
changed lines
  Added in v.1.8

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>