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

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

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]      
Removed from v.1.1  
changed lines
  Added in v.1.2

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