Annotation of gforth/libffi.fs, revision 1.1
1.1 ! pazsan 1: \ libffi.fs shared library support package 14aug05py
! 2:
! 3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005 Free Software Foundation, Inc.
! 4:
! 5: \ This file is part of Gforth.
! 6:
! 7: \ Gforth is free software; you can redistribute it and/or
! 8: \ modify it under the terms of the GNU General Public License
! 9: \ as published by the Free Software Foundation; either version 2
! 10: \ of the License, or (at your option) any later version.
! 11:
! 12: \ This program is distributed in the hope that it will be useful,
! 13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
! 14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! 15: \ GNU General Public License for more details.
! 16:
! 17: \ You should have received a copy of the GNU General Public License
! 18: \ along with this program; if not, write to the Free Software
! 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
! 20:
! 21: \ common stuff, same as fflib.fs
! 22:
! 23: Variable libs 0 libs !
! 24: \ links between libraries
! 25: Variable thisproc
! 26: Variable thislib
! 27:
! 28: Variable revdec revdec off
! 29: \ turn revdec on to compile bigFORTH libraries
! 30: Variable revarg revarg off
! 31: \ turn revarg on to compile declarations with reverse arguments
! 32: Variable legacy legacy off
! 33: \ turn legacy on to compile bigFORTH legacy libraries
! 34:
! 35: Vocabulary c-decl
! 36: Vocabulary cb-decl
! 37:
! 38: : @lib ( lib -- )
! 39: \G obtains library handle
! 40: cell+ dup 2 cells + count open-lib
! 41: dup 0= abort" Library not found" swap ! ;
! 42:
! 43: : @proc ( lib addr -- )
! 44: \G obtains symbol address
! 45: cell+ tuck cell+ @ count rot cell+ @
! 46: lib-sym dup 0= abort" Proc not found!" swap ! ;
! 47:
! 48: : proc, ( lib -- )
! 49: \G allocates and initializes proc stub
! 50: \G stub format:
! 51: \G linked list in library
! 52: \G address of proc
! 53: \G ptr to OS name of symbol as counted string
! 54: \G threaded code for invocation
! 55: here dup thisproc !
! 56: swap 2 cells + dup @ A, !
! 57: 0 , 0 A, ;
! 58:
! 59: Defer legacy-proc ' noop IS legacy-proc
! 60:
! 61: : proc: ( lib "name" -- )
! 62: \G Creates a named proc stub
! 63: Create proc, 0 also c-decl
! 64: legacy @ IF legacy-proc THEN
! 65: DOES> ( x1 .. xn -- r )
! 66: 3 cells + >r ;
! 67:
! 68: : library ( "name" "file" -- )
! 69: \G loads library "file" and creates a proc defining word "name"
! 70: \G library format:
! 71: \G linked list of libraries
! 72: \G library handle
! 73: \G linked list of library's procs
! 74: \G OS name of library as counted string
! 75: Create here libs @ A, dup libs !
! 76: 0 , 0 A, parse-name string, @lib
! 77: DOES> ( -- ) dup thislib ! proc: ;
! 78:
! 79: : init-shared-libs ( -- )
! 80: defers 'cold libs
! 81: 0 libs BEGIN @ dup WHILE dup REPEAT drop
! 82: BEGIN dup WHILE >r
! 83: r@ @lib
! 84: r@ 2 cells + BEGIN @ dup WHILE r@ over @proc REPEAT
! 85: drop rdrop
! 86: REPEAT drop ;
! 87:
! 88: ' init-shared-libs IS 'cold
! 89:
! 90: : symbol, ( "c-symbol" -- )
! 91: here thisproc @ 2 cells + ! parse-name s,
! 92: thislib @ thisproc @ @proc ;
! 93:
! 94: \ stuff for libffi
! 95:
! 96: \ libffi uses a parameter array for the input
! 97:
! 98: $20 Value maxargs
! 99:
! 100: Create retbuf 2 cells allot
! 101: Create argbuf maxargs 2* cells allot
! 102: Create argptr maxargs 0 [DO] argbuf [I] 2* cells + A, [LOOP]
! 103:
! 104: \ "forward" when revarg is on
! 105:
! 106: \ : >c+ ( char buf -- buf' ) tuck c! cell+ cell+ ;
! 107: : >i+ ( n buf -- buf' ) tuck ! cell+ cell+ ;
! 108: : >p+ ( addr buf -- buf' ) tuck ! cell+ cell+ ;
! 109: : >d+ ( d buf -- buf' ) dup >r ffi-2! r> cell+ cell+ ;
! 110: : >sf+ ( r buf -- buf' ) dup sf! cell+ cell+ ;
! 111: : >df+ ( r buf -- buf' ) dup df! cell+ cell+ ;
! 112:
! 113: \ "backward" when revarg is off
! 114:
! 115: \ : >c- ( char buf -- buf' ) tuck c! 2 cells - ;
! 116: : >i- ( n buf -- buf' ) 2 cells - tuck ! ;
! 117: : >p- ( addr buf -- buf' ) 2 cells - tuck ! ;
! 118: : >d- ( d buf -- buf' ) 2 cells - dup >r ffi-2! r> ;
! 119: : >sf- ( r buf -- buf' ) 2 cells - dup sf! ;
! 120: : >df- ( r buf -- buf' ) 2 cells - dup df! ;
! 121:
! 122: \ return value
! 123:
! 124: \ : c> ( -- c ) retbuf c@ ;
! 125: : i>x ( -- n ) retbuf @ ;
! 126: : p>x ( -- addr ) retbuf @ ;
! 127: : d>x ( -- d ) retbuf ffi-2@ ;
! 128: : sf>x ( -- r ) retbuf sf@ ;
! 129: : df>x ( -- r ) retbuf df@ ;
! 130:
! 131: wordlist constant cifs
! 132:
! 133: Variable cifbuf $40 allot \ maximum: 64 parameters
! 134: cifbuf cell+ cifbuf !
! 135: Variable args args off
! 136:
! 137: : argtype ( bkxt fwxt type "name" -- )
! 138: Create , , , DOES> 1 args +! ;
! 139:
! 140: : arg@ ( arg -- type pushxt )
! 141: dup @ swap cell+
! 142: revarg @ IF cell+ THEN @ ;
! 143:
! 144: : arg, ( xt -- )
! 145: dup ['] noop = IF drop EXIT THEN compile, ;
! 146:
! 147: : start, ( n -- ) cifbuf cell+ cifbuf !
! 148: revarg @ IF drop 0 ELSE 2* cells THEN argbuf +
! 149: postpone Literal ;
! 150:
! 151: : ffi-call, ( -- lit-cif )
! 152: postpone drop postpone argptr postpone retbuf
! 153: thisproc @ cell+ postpone literal postpone @
! 154: 0 postpone literal here cell -
! 155: postpone ffi-call ;
! 156:
! 157: : cif, ( n -- )
! 158: cifbuf @ c! 1 cifbuf +! ;
! 159:
! 160: : cif@ ( -- addr u )
! 161: cifbuf cell+ cifbuf @ over - ;
! 162:
! 163: : make-cif ( rtype -- addr ) cif,
! 164: cif@ cifs search-wordlist
! 165: IF execute EXIT THEN
! 166: get-current >r cifs set-current
! 167: cif@ nextname Create here >r
! 168: cif@ 1- bounds ?DO I c@ ffi-type , LOOP
! 169: r> cif@ 1- tuck + c@ ffi-type here dup >r 0 ffi-size allot
! 170: ffi-prep-cif throw
! 171: r> r> set-current ;
! 172:
! 173: : decl, ( 0 arg1 .. argn call rtype start -- )
! 174: start, { retxt rtype }
! 175: revdec @ IF 0 >r
! 176: BEGIN dup WHILE >r REPEAT
! 177: BEGIN r> dup WHILE arg@ arg, REPEAT
! 178: ffi-call, retxt compile, postpone EXIT
! 179: BEGIN dup WHILE cif, REPEAT drop
! 180: ELSE 0 >r
! 181: BEGIN dup WHILE arg@ arg, >r REPEAT drop
! 182: ffi-call, retxt compile, postpone EXIT
! 183: BEGIN r> dup WHILE cif, REPEAT drop
! 184: THEN rtype make-cif swap ! here thisproc @ 2 cells + ! ;
! 185:
! 186: : rettype ( endxt n "name" -- )
! 187: Create 2,
! 188: DOES> 2@ args @ decl, symbol, previous revarg off args off ;
! 189:
! 190: also c-decl definitions
! 191:
! 192: : <rev> revarg on ;
! 193:
! 194: ' >i+ ' >i- 6 argtype int
! 195: ' >p+ ' >p- &12 argtype ptr
! 196: ' >d+ ' >d- 8 argtype llong
! 197: ' >sf+ ' >sf- 9 argtype sf
! 198: ' >df+ ' >df- &10 argtype df
! 199:
! 200: ' noop 0 rettype (void)
! 201: ' i>x 6 rettype (int)
! 202: ' p>x &12 rettype (ptr)
! 203: ' d>x 8 rettype (llong)
! 204: ' sf>x 9 rettype (sf)
! 205: ' df>x &10 rettype (fp)
! 206:
! 207: previous definitions
! 208:
! 209: \ legacy support for old library interfaces
! 210: \ interface to old vararg stuff not implemented yet
! 211:
! 212: also c-decl
! 213:
! 214: :noname ( n 0 -- 0 int1 .. intn )
! 215: legacy @ 0< revarg !
! 216: swap 0 ?DO int LOOP (int)
! 217: ; IS legacy-proc
! 218:
! 219: : (int) ( n -- )
! 220: >r ' execute r> 0 ?DO int LOOP (int) ;
! 221: : (void) ( n -- )
! 222: >r ' execute r> 0 ?DO int LOOP (void) ;
! 223: : (float) ( n -- )
! 224: >r ' execute r> 0 ?DO df LOOP (fp) ;
! 225:
! 226: previous
! 227:
! 228: \ callback stuff
! 229:
! 230: 0 [IF]
! 231: Variable callbacks
! 232: \G link between callbacks
! 233:
! 234: : callback ( -- )
! 235: Create 0 ] postpone >r also cb-decl
! 236: DOES>
! 237: Create here >r 0 , callbacks @ A, r@ callbacks !
! 238: swap postpone Literal postpone call , postpone EXIT
! 239: r> dup cell+ cell+ alloc-callback swap !
! 240: DOES> @ ;
! 241:
! 242: : callback; ( 0 xt1 .. xtn -- )
! 243: BEGIN over WHILE compile, REPEAT
! 244: postpone r> postpone execute compile, drop
! 245: postpone EXIT postpone [ previous ; immediate
! 246:
! 247: : va-ret ( xt xt -- )
! 248: Create A, A, immediate
! 249: DOES> 2@ compile, ;
! 250:
! 251: : init-callbacks ( -- )
! 252: defers 'cold callbacks cell -
! 253: BEGIN cell+ @ dup WHILE dup cell+ cell+ alloc-callback over !
! 254: REPEAT drop ;
! 255:
! 256: ' init-callbacks IS 'cold
! 257:
! 258: also cb-decl definitions
! 259:
! 260: \ arguments
! 261:
! 262: ' va-arg-int Alias int
! 263: ' va-arg-float Alias sf
! 264: ' va-arg-double Alias df
! 265: ' va-arg-longlong Alias llong
! 266: ' va-arg-ptr Alias ptr
! 267:
! 268: ' va-return-void ' va-start-void va-ret (void)
! 269: ' va-return-int ' va-start-int va-ret (int)
! 270: ' va-return-float ' va-start-float va-ret (sf)
! 271: ' va-return-double ' va-start-double va-ret (fp)
! 272: ' va-return-longlong ' va-start-longlong va-ret (llong)
! 273: ' va-return-ptr ' va-start-ptr va-ret (ptr)
! 274:
! 275: previous definitions
! 276:
! 277: [THEN]
! 278:
! 279: \ testing stuff
! 280:
! 281: [ifdef] testing
! 282:
! 283: library libc libc.so.6
! 284:
! 285: libc sleep int (int) sleep
! 286: libc open int int ptr (int) open
! 287: libc lseek int llong int (llong) lseek64
! 288: libc read int ptr int (int) read
! 289: libc close int (int) close
! 290:
! 291: library libm libm.so.6
! 292:
! 293: libm fmodf sf sf (sf) fmodf
! 294: libm fmod df df (fp) fmod
! 295:
! 296: \ example for a windows callback
! 297:
! 298: callback wincall (int) int int int int callback;
! 299:
! 300: :noname ( a b c d -- e ) 2drop 2drop 0 ; wincall do_timer
! 301:
! 302: \ test a callback
! 303:
! 304: callback 2:1 (int) int int callback;
! 305:
! 306: : cb-test ( a b -- c )
! 307: cr ." Testing callback"
! 308: cr ." arguments: " .s
! 309: cr ." result " + .s cr ;
! 310: ' cb-test 2:1 c_plus
! 311:
! 312: : test c_plus av-start-int >r >r av-int-r av-int-r av-call-int ;
! 313:
! 314: \ 3 4 test
! 315:
! 316: \ bigFORTH legacy library test
! 317:
! 318: library libX11 libX11.so.6
! 319:
! 320: legacy on
! 321:
! 322: 1 libX11 XOpenDisplay XOpenDisplay ( name -- dpy )
! 323: 5 libX11 XInternAtoms XInternAtoms ( atoms flag count names dpy -- status )
! 324:
! 325: legacy off
! 326:
! 327: [then]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to libffi.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth