--- gforth/libffi.fs 2005/08/21 22:09:14 1.1 +++ gforth/libffi.fs 2007/12/31 18:40:24 1.14 @@ -1,12 +1,12 @@ \ 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 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ 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. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ common stuff, same as fflib.fs @@ -104,26 +103,28 @@ Create argptr maxargs 0 [DO] argbuf [I] \ "forward" when revarg is on \ : >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+ ; : >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+ ; : >df+ ( r buf -- buf' ) dup df! cell+ cell+ ; \ "backward" when revarg is off -\ : >c- ( char buf -- buf' ) tuck c! 2 cells - ; -: >i- ( n buf -- buf' ) 2 cells - tuck ! ; +: >i- ( n buf -- buf' ) 2 cells - tuck l! ; : >p- ( addr buf -- buf' ) 2 cells - tuck ! ; : >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! ; : >df- ( r buf -- buf' ) 2 cells - dup df! ; \ return value -\ : c> ( -- c ) retbuf c@ ; -: i>x ( -- n ) retbuf @ ; +: i>x ( -- n ) retbuf l@ ; +: is>x ( -- n ) retbuf sl@ ; : p>x ( -- addr ) retbuf @ ; +: dl>x ( -- d ) retbuf @ s>d ; : d>x ( -- d ) retbuf ffi-2@ ; : sf>x ( -- r ) retbuf sf@ ; : df>x ( -- r ) retbuf df@ ; @@ -131,7 +132,8 @@ Create argptr maxargs 0 [DO] argbuf [I] wordlist constant cifs Variable cifbuf $40 allot \ maximum: 64 parameters -cifbuf cell+ cifbuf ! +: cifreset cifbuf cell+ cifbuf ! ; +cifreset Variable args args off : argtype ( bkxt fwxt type "name" -- ) @@ -148,6 +150,10 @@ Variable args args off revarg @ IF drop 0 ELSE 2* cells THEN argbuf + 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 ) postpone drop postpone argptr postpone retbuf thisproc @ cell+ postpone literal postpone @ @@ -160,18 +166,20 @@ Variable args args off : cif@ ( -- addr u ) cifbuf cell+ cifbuf @ over - ; -: make-cif ( rtype -- addr ) cif, +: create-cif ( rtype -- addr ) cif, cif@ cifs search-wordlist IF execute EXIT THEN get-current >r cifs set-current cif@ nextname Create here >r - cif@ 1- bounds ?DO I c@ ffi-type , LOOP - r> cif@ 1- tuck + c@ ffi-type here dup >r 0 ffi-size allot - ffi-prep-cif throw - r> r> set-current ; + cif@ 1- bounds ?DO I c@ ffi-type , LOOP 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 -- ) - start, { retxt rtype } + start, { retxt rtype } cifreset revdec @ IF 0 >r BEGIN dup WHILE >r REPEAT BEGIN r> dup WHILE arg@ arg, REPEAT @@ -185,25 +193,36 @@ Variable args args off : rettype ( endxt n "name" -- ) 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 : revarg on ; ' >i+ ' >i- 6 argtype int +' >p+ ' >p- _long argtype long ' >p+ ' >p- &12 argtype ptr ' >d+ ' >d- 8 argtype llong +' >dl+ ' >dl- 6 argtype dlong ' >sf+ ' >sf- 9 argtype sf ' >df+ ' >df- &10 argtype df ' 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) ' d>x 8 rettype (llong) +' dl>x 6 rettype (dlong) ' sf>x 9 rettype (sf) ' df>x &10 rettype (fp) +: (addr) thisproc @ cell+ postpone Literal postpone @ postpone EXIT + drop symbol, previous revarg off args off ; + previous definitions \ legacy support for old library interfaces @@ -227,26 +246,34 @@ previous \ callback stuff -0 [IF] Variable 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 ( -- ) - Create 0 ] postpone >r also cb-decl + Create 0 ] postpone >r also cb-decl cifreset 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 - r> dup cell+ cell+ alloc-callback swap ! - DOES> @ ; + r@ cell+ cell+ alloc-callback r> ! ; -: callback; ( 0 xt1 .. xtn -- ) +: callback; ( 0 arg1 .. argn -- ) BEGIN over WHILE compile, REPEAT postpone r> postpone execute compile, drop postpone EXIT postpone [ previous ; immediate -: va-ret ( xt xt -- ) - Create A, A, immediate - DOES> 2@ compile, ; +: rettype' ( xt n -- ) + Create , A, immediate + DOES> 2@ rtype ! ; +: argtype' ( xt n -- ) + Create , A, immediate + DOES> 2@ cif, ; : init-callbacks ( -- ) defers 'cold callbacks cell - @@ -259,69 +286,22 @@ also cb-decl definitions \ arguments -' va-arg-int Alias int -' va-arg-float Alias sf -' va-arg-double Alias df -' va-arg-longlong Alias llong -' va-arg-ptr Alias ptr - -' va-return-void ' va-start-void va-ret (void) -' va-return-int ' va-start-int va-ret (int) -' va-return-float ' va-start-float va-ret (sf) -' va-return-double ' va-start-double va-ret (fp) -' va-return-longlong ' va-start-longlong va-ret (llong) -' va-return-ptr ' va-start-ptr va-ret (ptr) +' ffi-arg-int 6 argtype' int +' ffi-arg-float 9 argtype' sf +' ffi-arg-double &10 argtype' df +' ffi-arg-long _long argtype' long +' ffi-arg-longlong 8 argtype' llong +' ffi-arg-dlong 6 argtype' dlong +' ffi-arg-ptr &12 argtype' ptr + +' ffi-ret-void 0 rettype' (void) +' ffi-ret-int 6 rettype' (int) +' 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 - -[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]