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

version 1.1, 2005/08/21 22:09:14 version 1.27, 2008/08/05 09:17:06
Line 1 Line 1
 \ libffi.fs     shared library support package          14aug05py  \ libffi.fs     shared library support package          14aug05py
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2006,2007,2008 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   \ replacements for former primitives
   \ note that the API functions have their arguments reversed and other
   \ deviations.
   
   c-library libffi
   s" ffi" add-lib
   
   s" os-type" environment? [IF] s" darwin" string-prefix?
   [IF]
       \c #define MACOSX
       \c #include <ffi/ffi.h>
   [ELSE]
       \c #include <ffi.h>
   [THEN]
   [ELSE]
       \c #include <ffi.h>
   [THEN]
   \c extern Cell *gforth_RP;
   \c extern unsigned char *gforth_LP;
   \c static void **gforth_clist;
   \c static void *gforth_ritem;
   \c typedef void *Label;
   \c typedef Label *Xt;
   \c Label *gforth_engine(Xt *ip, Cell *sp, Cell *rp0, Float *fp, unsigned char *lp);
   \c static void gforth_callback_ffi(ffi_cif * cif, void * resp, void ** args, void * ip)
   \c {
   \c   Cell *rp1 = gforth_RP;
   \c   Cell *sp = gforth_SP;
   \c   Float *fp = gforth_FP;
   \c   unsigned char *lp = gforth_LP;
   \c   void ** clist = gforth_clist;
   \c   void * ritem = gforth_ritem;
   \c 
   \c   gforth_clist = args;
   \c   gforth_ritem = resp;
   \c 
   \c   gforth_engine((Xt *)ip, sp, rp1, fp, lp);
   \c 
   \c   /* restore global variables */
   \c   gforth_RP = rp1;
   \c   gforth_SP = sp;
   \c   gforth_FP = fp;
   \c   gforth_LP = lp;
   \c   gforth_clist = clist;
   \c   gforth_ritem = ritem;
   \c }
   
   \c static void* ffi_types[] =
   \c     { &ffi_type_void,
   \c       &ffi_type_uint8, &ffi_type_sint8,
   \c       &ffi_type_uint16, &ffi_type_sint16,
   \c       &ffi_type_uint32, &ffi_type_sint32,
   \c       &ffi_type_uint64, &ffi_type_sint64,
   \c       &ffi_type_float, &ffi_type_double, &ffi_type_longdouble,
   \c       &ffi_type_pointer };
   \c #define ffi_type(n) (ffi_types[n])
   c-function ffi-type ffi_type n -- a
   
   \c static int ffi_sizes[] = { sizeof(ffi_cif), sizeof(ffi_closure) };
   \c #define ffi_size(n1) (ffi_sizes[n1])
   c-function ffi-size ffi_size n -- n
   
   \c #define ffi_prep_cif1(atypes, n, rtype, cif) \
   \c           ffi_prep_cif((ffi_cif *)cif, FFI_DEFAULT_ABI, n, \
   \c                        (ffi_type *)rtype, (ffi_type **)atypes)
   c-function ffi-prep-cif ffi_prep_cif1 a n a a -- n
   
   \c #define ffi_call1(a_avalues, a_rvalue ,a_ip ,a_cif) \
   \c             ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, \
   \c                      (void *)a_rvalue, (void **)a_avalues)
   c-function ffi-call ffi_call1 a a a a -- void
   
   \c #define ffi_prep_closure1(a_ip, a_cif, a_closure) \
   \c              ffi_prep_closure((ffi_closure *)a_closure, (ffi_cif *)a_cif, gforth_callback_ffi, (void *)a_ip)
   c-function ffi-prep-closure ffi_prep_closure1 a a a -- n
   
   \ !! use ud?
   \c #define ffi_2fetch(a_addr) (*(long long *)a_addr)
   c-function ffi-2@ ffi_2fetch a -- d
   
   \c #define ffi_2store(d,a_addr) ((*(long long *)a_addr) = (long long)d)
   c-function ffi-2! ffi_2store d a -- void
   
   \c #define ffi_arg_int() (*(int *)(*gforth_clist++))
   c-function ffi-arg-int ffi_arg_int -- n
   
   \c #define ffi_arg_long() (*(long *)(*gforth_clist++))
   c-function ffi-arg-long ffi_arg_long -- n
   
   \c #define ffi_arg_longlong() (*(long long *)(*gforth_clist++))
   c-function ffi-arg-longlong ffi_arg_longlong -- d
   
   \ !! correct?  The primitive is different, but looks funny
   c-function ffi-arg-dlong ffi_arg_long -- d
   
   \c #define ffi_arg_ptr() (*(char **)(*gforth_clist++))
   c-function ffi-arg-ptr ffi_arg_ptr -- a
   
   \c #define ffi_arg_float() (*(float *)(*gforth_clist++))
   c-function ffi-arg-float ffi_arg_float -- r
   
   \c #define ffi_arg_double() (*(double *)(*gforth_clist++))
   c-function ffi-arg-double ffi_arg_double -- r
   
   : ffi-ret-void ( -- )
       0 (bye) ;
   
   \c #define ffi_ret_int1(w) (*(int*)(gforth_ritem) = w)
   c-function ffi-ret-int1 ffi_ret_int1 n -- void
   : ffi-ret-int ( w -- ) ffi-ret-int1 ffi-ret-void ;
   
   \c #define ffi_ret_longlong1(d) (*(long long *)(gforth_ritem) = d)
   c-function ffi-ret-longlong1 ffi_ret_longlong1 d -- void
   : ffi-ret-longlong ( d -- ) ffi-ret-longlong1 ffi-ret-void ;
   
   \c #define ffi_ret_dlong1(d) (*(long *)(gforth_ritem) = d)
   c-function ffi-ret-dlong1 ffi_ret_dlong1 d -- void
   : ffi-ret-dlong ( d -- ) ffi-ret-dlong1 ffi-ret-void ;
   
   c-function ffi-ret-long1 ffi_ret_dlong1 n -- void
   : ffi-ret-long ( n -- ) ffi-ret-long1 ffi-ret-void ;
   
   \c #define ffi_ret_ptr1(w) (*(char **)(gforth_ritem) = w)
   c-function ffi-ret-ptr1 ffi_ret_ptr1 a -- void
   : ffi-ret-ptr ( a -- ) ffi-ret-ptr1 ffi-ret-void ;
   
   \c #define ffi_ret_float1(r) (*(float *)(gforth_ritem) = r)
   c-function ffi-ret-float1 ffi_ret_float1 r -- void
   : ffi-ret-float ( r -- ) ffi-ret-float1 ffi-ret-void ;
   
   \c #define ffi_ret_double1(r) (*(double *)(gforth_ritem) = r)
   c-function ffi-ret-double1 ffi_ret_double1 r -- void
   : ffi-ret-double ( r -- ) ffi-ret-double1 ffi-ret-void ;
   end-c-library
   
 \ common stuff, same as fflib.fs  \ common stuff, same as fflib.fs
   
Line 104  Create argptr maxargs 0 [DO]  argbuf [I] Line 238  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+ ;
   : >dl+ ( d buf -- buf' )     nip dup >r  ! r> cell+ cell+ ;
 : >sf+ ( r buf -- buf' )     dup   sf!    cell+ cell+ ;  : >sf+ ( r buf -- buf' )     dup   sf!    cell+ cell+ ;
 : >df+ ( r buf -- buf' )     dup   df!    cell+ cell+ ;  : >df+ ( r buf -- buf' )     dup   df!    cell+ cell+ ;
   
 \ "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> ;
   : >dl- ( d buf -- buf' )     2 cells - nip dup >r ! r> ;
 : >sf- ( r buf -- buf' )     2 cells - dup   sf! ;  : >sf- ( r buf -- buf' )     2 cells - dup   sf! ;
 : >df- ( r buf -- buf' )     2 cells - dup   df! ;  : >df- ( r buf -- buf' )     2 cells - dup   df! ;
   
 \ 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 @ ;
   : dl>x   ( -- d ) retbuf @ s>d ;
 : d>x   ( -- d )  retbuf ffi-2@ ;  : d>x   ( -- d )  retbuf ffi-2@ ;
 : sf>x  ( -- r )  retbuf sf@ ;  : sf>x  ( -- r )  retbuf sf@ ;
 : df>x  ( -- r )  retbuf df@ ;  : df>x  ( -- r )  retbuf df@ ;
Line 131  Create argptr maxargs 0 [DO]  argbuf [I] Line 267  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 285  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 301  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 328  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 ;
   
   6 1 cells 4 > 2* - Constant _long
   
 also c-decl definitions  also c-decl definitions
   
 : <rev>  revarg on ;  : <rev>  revarg on ;
   
 ' >i+  ' >i-    6 argtype int  ' >i+  ' >i-    6 argtype int
   ' >p+  ' >p-    _long argtype long
 ' >p+  ' >p-  &12 argtype ptr  ' >p+  ' >p-  &12 argtype ptr
 ' >d+  ' >d-    8 argtype llong  ' >d+  ' >d-    8 argtype llong
   ' >dl+ ' >dl-   6 argtype dlong
 ' >sf+ ' >sf-   9 argtype sf  ' >sf+ ' >sf-   9 argtype sf
 ' >df+ ' >df- &10 argtype df  ' >df+ ' >df- &10 argtype df
   : ints 0 ?DO int LOOP ;
   
 ' noop   0 rettype (void)  ' noop   0 rettype (void)
 ' i>x    6 rettype (int)  ' is>x   6 rettype (int)
   ' i>x    5 rettype (uint)
   ' p>x    _long rettype (long)
 ' p>x  &12 rettype (ptr)  ' p>x  &12 rettype (ptr)
 ' d>x    8 rettype (llong)  ' d>x    8 rettype (llong)
   ' dl>x   6 rettype (dlong)
 ' 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 382  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 -- )  \ !! is the stack effect right?  or is it ( 0 ret arg1 .. argn -- ) ?
   : 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
       \ !! should we put ]] 0 (bye) [[ here?
       \ !! is the EXIT ever executed?
     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 425  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-long       _long argtype' long
 ' va-arg-ptr      Alias ptr  ' ffi-arg-longlong   8 argtype' llong
   ' ffi-arg-dlong      6 argtype' dlong
 ' va-return-void     ' va-start-void     va-ret (void)  ' ffi-arg-ptr      &12 argtype' ptr
 ' va-return-int      ' va-start-int      va-ret (int)  : ints ( n -- ) 0 ?DO postpone int LOOP ; immediate
 ' va-return-float    ' va-start-float    va-ret (sf)  
 ' va-return-double   ' va-start-double   va-ret (fp)  ' ffi-ret-void       0 rettype' (void)
 ' va-return-longlong ' va-start-longlong va-ret (llong)  ' ffi-ret-int        6 rettype' (int)
 ' va-return-ptr      ' va-start-ptr      va-ret (ptr)  ' ffi-ret-float      9 rettype' (sf)
   ' ffi-ret-double   &10 rettype' (fp)
   ' ffi-ret-longlong   8 rettype' (llong)
   ' ffi-ret-long       _long rettype' (long)
   ' ffi-ret-dlong      _long rettype' (dlong)
   ' 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.27


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