--- gforth/lib.fs 1998/07/08 16:47:31 1.3 +++ gforth/lib.fs 2008/04/22 14:50:59 1.24 @@ -1,12 +1,12 @@ \ lib.fs shared library support package 11may97py -\ Copyright (C) 1995-1997 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2006,2007 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,108 +15,92 @@ \ 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., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. -Create icall-table - ] icall0 ;s icall1 ;s icall2 ;s icall3 ;s icall4 ;s icall5 ;s icall6 ;s - NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap - NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap icall20 ;s [ -Create fcall-table - ] fcall0 ;s fcall1 ;s fcall2 ;s fcall3 ;s fcall4 ;s fcall5 ;s fcall6 ;s - NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap - NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap fcall20 ;s [ - -Variable libs 0 libs ! -\G links between libraries - -: @lib ( lib -- ) - \G obtains library handle - cell+ dup 2 cells + count open-lib - dup 0= abort" Library not found" swap ! ; - -: @proc ( lib addr -- ) - \G obtains symbol address - cell+ tuck 2 cells + count rot cell+ @ - lib-sym dup 0= abort" Proc not found!" swap cell+ ! ; - -: proc, ( pars type lib addr -- ) - \G allocates and initializes proc stub - \G stub format: - \G linked list in library - \G address of proc - \G offset in lcall1-table to call proc - \G OS name of symbol as counted string - here 2dup swap 2 cells + dup @ A, ! - 2swap 1 and IF fcall-table ELSE icall-table THEN swap - cells 2* + , 0 , bl sword string, @proc ; - --1 Constant (addr) - 0 Constant (int) - 1 Constant (float) - 2 Constant (void) - 4 Constant (int...) - 5 Constant (float...) - 6 Constant (void...) - -: proc: ( pars type lib "name" "string" -- ) - \G Creates a named proc stub - Create proc, -DOES> ( x1 .. xn -- r ) - cell+ 2@ >r ; - -: vaproc: ( pars type lib "name" "string" -- ) - \G Creates a named proc stub with variable arguments - Create proc, -DOES> ( x1 .. xn n -- r ) - cell+ 2@ rot 2* cells + >r ; - -: (>void) >r ; - -: vproc: ( pars type lib "name" "string" -- ) - \G Creates a named proc stub for void functions - Create proc, -DOES> ( x1 .. xn -- ) - cell+ 2@ (>void) drop ; - -: vvaproc: ( pars type lib "name" "string" -- ) - \G Creates a named proc stub with variable arguments, void return - Create proc, -DOES> ( x1 .. xn n -- ) - cell+ 2@ rot 2* cells + (>void) drop ; - -: label: ( type lib "name" "string" -- ) - \G Creates a named label stub - -1 -rot Create proc, -DOES> ( -- addr ) - [ 2 cells ] Literal + @ ; - -: library ( "name" "file" -- ) - \G loads library "file" and creates a proc defining word "name" - \G library format: - \G linked list of libraries - \G library handle - \G linked list of library's procs - \G OS name of library as counted string - Create here libs @ A, dup libs ! - 0 , 0 A, bl sword string, @lib -DOES> ( pars/ type -- ) - over -1 = IF label: - ELSE - over 4 and IF - over 2 and IF vvaproc: ELSE vaproc: THEN - ELSE - over 2 and IF vproc: ELSE proc: THEN - THEN - THEN ; - -: init-shared-libs ( -- ) - defers 'cold libs - 0 libs BEGIN @ dup WHILE dup REPEAT drop - BEGIN dup WHILE >r - r@ @lib - r@ 2 cells + BEGIN @ dup WHILE r@ over @proc REPEAT - drop rdrop - REPEAT drop ; +s" libavcall.so" open-lib 0<> +s" libcallback.so" open-lib 0<> and +s" libvacall.so" open-lib 0<> and +s" libtrampoline.so" open-lib 0<> and [if] + .( including fflib.fs [ffcall] ) + include fflib.fs +[ELSE] + s" libffi" open-lib [if] + .( including libffi.fs ) + include libffi.fs + [ELSE] + .( Neither libffi nor ffcall are available ) cr + abort + .( Using oldlib.fs; incompatible with fflib.fs and libffi.fs) cr + include oldlib.fs + [THEN] +[THEN] + +\ testing stuff + +[IFUNDEF] libc + s" os-type" environment? [IF] + 2dup s" linux-gnu" str= [IF] 2drop + library libc libc.so.6 + [ELSE] 2dup s" cygwin" str= [IF] 2drop + library libc cygwin1.dll + [ELSE] 2dup s" bsd" search nip nip [IF] 2drop + library libc libc.so + [ELSE] 2dup s" darwin" string-prefix? [IF] 2drop + library libc libc.dylib + [ELSE] 2drop \ or add your stuff here + [THEN] + [THEN] + [THEN] + [THEN] + [THEN] +[THEN] + +[ifdef] testing + +library libc libc.so.6 + +libc sleep int (int) sleep +libc open ptr int int (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 + +fptr 2:1call int int (int) + +: test c_plus 2:1call ; + +\ 3 4 test + +\ bigFORTH legacy library test + +library libX11 libX11.so.6 -' init-shared-libs IS 'cold +legacy on + +1 libX11 XOpenDisplay XOpenDisplay ( name -- dpy ) +5 libX11 XInternAtoms XInternAtoms ( atoms flag count names dpy -- status ) + +legacy off + +[then]