version 1.6, 2005/12/04 13:46:12
|
version 1.14, 2007/12/31 18:40:24
|
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 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. |
|
|
|
\ common stuff, same as fflib.fs |
\ common stuff, same as fflib.fs |
|
|
Line 104 Create argptr maxargs 0 [DO] argbuf [I]
|
Line 103 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 |
|
|
: >i- ( n buf -- buf' ) 2 cells - tuck t! ; |
: >i- ( n buf -- buf' ) 2 cells - tuck l! ; |
: >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 |
|
|
: i>x ( -- n ) retbuf t@ ; |
: i>x ( -- n ) retbuf l@ ; |
: is>x ( -- n ) retbuf tx@ ; |
: 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 148 Variable args args off
|
Line 150 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 187 Variable args args off
|
Line 193 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 |
|
|
' noop 0 rettype (void) |
' noop 0 rettype (void) |
' is>x 6 rettype (int) |
' is>x 6 rettype (int) |
' i>x 6 rettype (uint) |
' 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) |
|
|
Line 238 Variable callbacks
|
Line 251 Variable callbacks
|
|
|
Variable rtype |
Variable rtype |
|
|
: alloc-callback ( -- addr ) |
: alloc-callback ( ip -- addr ) |
rtype @ create-cif |
rtype @ make-cif here 1 ffi-size allot |
cif@ 1- tuck + c@ ffi-type here dup >r 1 ffi-size allot |
dup >r ffi-prep-closure throw r> ; |
ffi-prep-closure throw r> ; |
|
|
|
: callback ( -- ) |
: callback ( -- ) |
Create 0 ] postpone >r also cb-decl cifreset |
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 arg1 .. argn -- ) |
: callback; ( 0 arg1 .. argn -- ) |
BEGIN over WHILE compile, REPEAT |
BEGIN over WHILE compile, REPEAT |
Line 277 also cb-decl definitions
|
Line 289 also cb-decl definitions
|
' ffi-arg-int 6 argtype' int |
' ffi-arg-int 6 argtype' int |
' ffi-arg-float 9 argtype' sf |
' ffi-arg-float 9 argtype' sf |
' ffi-arg-double &10 argtype' df |
' ffi-arg-double &10 argtype' df |
|
' ffi-arg-long _long argtype' long |
' ffi-arg-longlong 8 argtype' llong |
' ffi-arg-longlong 8 argtype' llong |
|
' ffi-arg-dlong 6 argtype' dlong |
' ffi-arg-ptr &12 argtype' ptr |
' ffi-arg-ptr &12 argtype' ptr |
|
|
' ffi-ret-void 0 rettype' (void) |
' ffi-ret-void 0 rettype' (void) |
Line 285 also cb-decl definitions
|
Line 299 also cb-decl definitions
|
' ffi-ret-float 9 rettype' (sf) |
' ffi-ret-float 9 rettype' (sf) |
' ffi-ret-double &10 rettype' (fp) |
' ffi-ret-double &10 rettype' (fp) |
' ffi-ret-longlong 8 rettype' (llong) |
' ffi-ret-longlong 8 rettype' (llong) |
|
' ffi-ret-long _long rettype' (long) |
|
' ffi-ret-dlong _long rettype' (dlong) |
' ffi-ret-ptr &12 rettype' (ptr) |
' ffi-ret-ptr &12 rettype' (ptr) |
|
|
previous definitions |
previous definitions |