| \ libffi.fs shared library support package 14aug05py |
\ libffi.fs shared library support package 14aug05py |
| |
|
| \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2006,2007 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2006,2007,2008,2009 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| \ note that the API functions have their arguments reversed and other |
\ note that the API functions have their arguments reversed and other |
| \ deviations. |
\ deviations. |
| |
|
| require libcc.fs |
c-library libffi |
| |
s" ffi" add-lib |
| |
|
| s" libffi" open-lib 0= [if] |
\ The ffi.h of XCode needs the following line, and it should not hurt elsewhere |
| .( cannot open libffi ) cr abort |
\c #define MACOSX |
| [then] |
include-ffi.h-string save-c-prefix-line \ #include <ffi.h> |
| |
\c #include <stdio.h> |
| \c #include <ffi.h> |
|
| \c static Cell *gforth_RP; |
|
| \c static char *gforth_LP; |
|
| \c static void **gforth_clist; |
\c static void **gforth_clist; |
| \c static void *gforth_ritem; |
\c static void *gforth_ritem; |
| |
\c #ifndef HAS_BACKLINK |
| |
\c static void **saved_gforth_pointers; |
| |
\c #endif |
| \c typedef void *Label; |
\c typedef void *Label; |
| \c typedef Label *Xt; |
\c typedef Label *Xt; |
| \c static void gforth_callback_ffi(ffi_cif * cif, void * resp, void ** args, void * ip) |
\c static void gforth_callback_ffi(ffi_cif * cif, void * resp, void ** args, void * ip) |
| \c { |
\c { |
| |
\c #ifndef HAS_BACKLINK |
| |
\c void **gforth_pointers = saved_gforth_pointers; |
| |
\c #endif |
| |
\c { |
| \c Cell *rp1 = gforth_RP; |
\c Cell *rp1 = gforth_RP; |
| \c Cell *sp = gforth_SP; |
\c Cell *sp = gforth_SP; |
| \c Float *fp = gforth_FP; |
\c Float *fp = gforth_FP; |
| \c char *lp = gforth_LP; |
\c unsigned char *lp = gforth_LP; |
| \c void ** clist = gforth_clist; |
\c void ** clist = gforth_clist; |
| \c void * ritem = gforth_ritem; |
\c void * ritem = gforth_ritem; |
| \c |
\c |
| \c gforth_clist = clist; |
\c gforth_clist = clist; |
| \c gforth_ritem = ritem; |
\c gforth_ritem = ritem; |
| \c } |
\c } |
| |
\c } |
| |
|
| \c static void* ffi_types[] = |
\c static void* ffi_types[] = |
| \c { &ffi_type_void, |
\c { &ffi_type_void, |
| \c (ffi_type *)rtype, (ffi_type **)atypes) |
\c (ffi_type *)rtype, (ffi_type **)atypes) |
| c-function ffi-prep-cif ffi_prep_cif1 a n a a -- n |
c-function ffi-prep-cif ffi_prep_cif1 a n a a -- n |
| |
|
| |
\c #ifdef HAS_BACKLINK |
| |
\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 #else |
| \c #define ffi_call1(a_avalues, a_rvalue ,a_ip ,a_cif) \ |
\c #define ffi_call1(a_avalues, a_rvalue ,a_ip ,a_cif) \ |
| |
\c (saved_gforth_pointers = gforth_pointers), \ |
| \c ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, \ |
\c ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, \ |
| \c (void *)a_rvalue, (void **)a_avalues) |
\c (void *)a_rvalue, (void **)a_avalues) |
| |
\c #endif |
| c-function ffi-call ffi_call1 a a a a -- void |
c-function ffi-call ffi_call1 a a a a -- void |
| |
|
| \c #define ffi_prep_closure1(a_ip, a_cif, a_closure) \ |
\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 ffi_prep_closure((ffi_closure *)a_closure, (ffi_cif *)a_cif, gforth_callback_ffi, (void *)a_ip) |
| c-function ffi-prep-closure a a a -- n |
c-function ffi-prep-closure ffi_prep_closure1 a a a -- n |
| |
|
| \ !! use ud? |
\ !! use ud? |
| \c #define ffi_2fetch(a_addr) (*(long long *)a_addr) |
\c #define ffi_2fetch(a_addr) (*(long long *)a_addr) |
| \c #define ffi_ret_double1(r) (*(double *)(gforth_ritem) = r) |
\c #define ffi_ret_double1(r) (*(double *)(gforth_ritem) = r) |
| c-function ffi-ret-double1 ffi_ret_double1 r -- void |
c-function ffi-ret-double1 ffi_ret_double1 r -- void |
| : ffi-ret-double ( r -- ) ffi-ret-double1 ffi-ret-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 |
| |
|
| here thisproc @ 2 cells + ! parse-name s, |
here thisproc @ 2 cells + ! parse-name s, |
| thislib @ thisproc @ @proc ; |
thislib @ thisproc @ @proc ; |
| |
|
| |
: func@ >body cell+ @ ; |
| |
: func' ' func@ ; |
| |
: [func'] postpone ['] postpone func@ ; immediate restrict |
| |
|
| \ stuff for libffi |
\ stuff for libffi |
| |
|
| \ libffi uses a parameter array for the input |
\ libffi uses a parameter array for the input |
| : sf>x ( -- r ) retbuf sf@ ; |
: sf>x ( -- r ) retbuf sf@ ; |
| : df>x ( -- r ) retbuf df@ ; |
: df>x ( -- r ) retbuf df@ ; |
| |
|
| wordlist constant cifs |
table constant cifs |
| |
|
| Variable cifbuf $40 allot \ maximum: 64 parameters |
Variable cifbuf $40 allot \ maximum: 64 parameters |
| : cifreset cifbuf cell+ cifbuf ! ; |
: cifreset cifbuf cell+ cifbuf ! ; |
| ' >dl+ ' >dl- 6 argtype dlong |
' >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) |
| ' is>x 6 rettype (int) |
' is>x 6 rettype (int) |
| ' ffi-arg-longlong 8 argtype' llong |
' ffi-arg-longlong 8 argtype' llong |
| ' ffi-arg-dlong 6 argtype' dlong |
' ffi-arg-dlong 6 argtype' dlong |
| ' ffi-arg-ptr &12 argtype' ptr |
' ffi-arg-ptr &12 argtype' ptr |
| |
: ints ( n -- ) 0 ?DO postpone int LOOP ; immediate |
| |
|
| ' ffi-ret-void 0 rettype' (void) |
' ffi-ret-void 0 rettype' (void) |
| ' ffi-ret-int 6 rettype' (int) |
' ffi-ret-int 6 rettype' (int) |
