[gforth] / gforth / libffi.fs  

gforth: gforth/libffi.fs

Diff for /gforth/libffi.fs between version 1.1 and 1.2

version 1.1, Sun Aug 21 22:09:14 2005 UTC version 1.2, Sun Nov 20 23:15:42 2005 UTC
Line 112 
Line 112 
   
 \ "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 
Line 120 
   
 \ 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 
Line 129 
 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 
Line 170 
     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 
Line 226 
   
 \ 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 
Line 269 
   
 \ 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]  

Generate output suitable for use with a patch program
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help