Diff for /gforth/fflib.fs between versions 1.6 and 1.27

version 1.6, 2005/08/21 22:09:14 version 1.27, 2009/02/24 22:57:48
Line 1 Line 1
 \ lib.fs        shared library support package          16aug03py  \ lib.fs        shared library support package          16aug03py
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2006,2007,2008 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.  
   \ replacements for former primitives
   c-library fflib
   s" avcall" add-lib
   s" callback" add-lib
   
   \c #include <avcall.h>
   \c #include <callback.h>
   \c static av_alist alist;
   \c static va_alist gforth_clist;
   \c #ifndef HAS_BACKLINK
   \c static void **saved_gforth_pointers;
   \c #endif
   \c static float frv;
   \c static int irv;
   \c static double drv;
   \c static long long llrv;
   \c static void * prv;
   \c typedef void *Label;
   \c typedef Label *Xt;
   \c 
   \c void gforth_callback_ffcall(Xt* fcall, void * alist)
   \c {
   \c #ifndef HAS_BACKLINK
   \c   void **gforth_pointers = saved_gforth_pointers;
   \c #endif
   \c   {
   \c     /* save global valiables */
   \c     Cell *rp = gforth_RP;
   \c     Cell *sp = gforth_SP;
   \c     Float *fp = gforth_FP;
   \c     char *lp = gforth_LP;
   \c     va_alist clist = gforth_clist;
   \c 
   \c     gforth_clist = (va_alist)alist;
   \c 
   \c     gforth_engine(fcall, sp, rp, fp, lp, gforth_UP);
   \c 
   \c     /* restore global variables */
   \c     gforth_RP = rp;
   \c     gforth_SP = sp;
   \c     gforth_FP = fp;
   \c     gforth_LP = lp;
   \c     gforth_clist = clist;
   \c   }
   \c }
   
   \c #define av_start_void1(c_addr) av_start_void(alist, c_addr)
   c-function av-start-void av_start_void1 a -- void
   \c #define av_start_int1(c_addr) av_start_int(alist, c_addr, &irv)
   c-function av-start-int av_start_int1 a -- void
   \c #define av_start_float1(c_addr) av_start_float(alist, c_addr, &frv)
   c-function av-start-float av_start_float1 a -- void
   \c #define av_start_double1(c_addr) av_start_double(alist, c_addr, &drv)
   c-function av-start-double av_start_double1 a -- void
   \c #define av_start_longlong1(c_addr) av_start_longlong(alist, c_addr, &llrv)
   c-function av-start-longlong av_start_longlong1 a -- void
   \c #define av_start_ptr1(c_addr) av_start_ptr(alist, c_addr, void *, &prv)
   c-function av-start-ptr av_start_ptr1 a -- void
   \c #define av_int1(w) av_int(alist,w)
   c-function av-int av_int1 n -- void
   \c #define av_float1(r) av_float(alist,r)
   c-function av-float av_float1 r -- void
   \c #define av_double1(r) av_double(alist,r)
   c-function av-double av_double1 r -- void
   \c #define av_longlong1(d) av_longlong(alist,d)
   c-function av-longlong av_longlong1 d -- void
   \c #define av_ptr1(a) av_ptr(alist, void *, a)
   c-function av-ptr av_ptr1 a -- void
   \c #define av_call_void() av_call(alist)
   c-function av-call-void av_call_void -- void
   \c #define av_call_int() (av_call(alist), irv)
   c-function av-call-int av_call_int -- n
   \c #define av_call_float() (av_call(alist), frv)
   c-function av-call-float av_call_float -- r
   \c #define av_call_double() (av_call(alist), drv)
   c-function av-call-double av_call_double -- r
   \c #define av_call_longlong() (av_call(alist), llrv)
   c-function av-call-longlong av_call_longlong -- d
   \c #define av_call_ptr() (av_call(alist), prv)
   c-function av-call-ptr av_call_ptr -- a
   \c #define alloc_callback1(a_ip) alloc_callback(gforth_callback_ffcall, (Xt *)a_ip)
   c-function alloc-callback alloc_callback1 a -- a
   \c #define va_start_void1() va_start_void(gforth_clist)
   c-function va-start-void va_start_void1 -- void
   \c #define va_start_int1() va_start_int(gforth_clist)
   c-function va-start-int va_start_int1 -- void
   \c #define va_start_longlong1() va_start_longlong(gforth_clist)
   c-function va-start-longlong va_start_longlong1 -- void
   \c #define va_start_ptr1() va_start_ptr(gforth_clist, (char *))
   c-function va-start-ptr va_start_ptr1 -- void
   \c #define va_start_float1() va_start_float(gforth_clist)
   c-function va-start-float va_start_float1 -- void
   \c #define va_start_double1() va_start_double(gforth_clist)
   c-function va-start-double va_start_double1 -- void
   \c #define va_arg_int1() va_arg_int(gforth_clist)
   c-function va-arg-int va_arg_int1 -- n
   \c #define va_arg_longlong1() va_arg_longlong(gforth_clist)
   c-function va-arg-longlong va_arg_longlong1 -- d
   \c #define va_arg_ptr1() va_arg_ptr(gforth_clist, char *)
   c-function va-arg-ptr va_arg_ptr1 -- a
   \c #define va_arg_float1() va_arg_float(gforth_clist)
   c-function va-arg-float va_arg_float1 -- r
   \c #define va_arg_double1() va_arg_double(gforth_clist)
   c-function va-arg-double va_arg_double1 -- r
   \c #define va_return_void1() va_return_void(gforth_clist)
   c-function va-return-void1 va_return_void1 -- void
   \c #define va_return_int1(w) va_return_int(gforth_clist,w)
   c-function va-return-int1 va_return_int1 n -- void
   \c #define va_return_ptr1(w) va_return_ptr(gforth_clist, void *, w)
   c-function va-return-ptr1 va_return_ptr1 a -- void
   \c #define va_return_longlong1(d) va_return_longlong(gforth_clist,d)
   c-function va-return-longlong1 va_return_longlong1 d -- void
   \c #define va_return_float1(r) va_return_float(gforth_clist,r)
   c-function va-return-float1 va_return_float1 r -- void
   \c #define va_return_double1(r) va_return_double(gforth_clist,r)
   c-function va-return-double1 va_return_double1 r -- void
   end-c-library
   
   : av-int-r      2r> >r av-int ;
   : av-float-r    f@local0 lp+ av-float ;
   : av-double-r   f@local0 lp+ av-double ;
   : av-longlong-r r> 2r> rot >r av-longlong ;
   : av-ptr-r      2r> >r av-ptr ;
   : va-return-void      va-return-void1     0 (bye) ;
   : va-return-int       va-return-int1      0 (bye) ;
   : va-return-ptr       va-return-ptr1      0 (bye) ;
   : va-return-longlong  va-return-longlong1 0 (bye) ;
   : va-return-float     va-return-float1    0 (bye) ;
   : va-return-double    va-return-double1   0 (bye) ;
   
   \ start of fflib proper
   
 Variable libs 0 libs !  Variable libs 0 libs !
 \ links between libraries  \ links between libraries
Line 63  Defer legacy-proc  ' noop IS legacy-proc Line 194  Defer legacy-proc  ' noop IS legacy-proc
 DOES> ( x1 .. xn -- r )  DOES> ( x1 .. xn -- r )
     dup cell+ @ swap 3 cells + >r ;      dup cell+ @ swap 3 cells + >r ;
   
   Variable ind-call ind-call off
   : fptr ( "name" -- )
       Create here thisproc ! 0 , 0 , 0 ,  0 also c-decl  ind-call on
       DOES>  3 cells + >r ;
   
 : library ( "name" "file" -- )  : library ( "name" "file" -- )
 \G loads library "file" and creates a proc defining word "name"  \G loads library "file" and creates a proc defining word "name"
 \G library format:  \G library format:
Line 75  DOES> ( x1 .. xn -- r ) Line 211  DOES> ( x1 .. xn -- r )
 DOES> ( -- )  dup thislib ! proc: ;  DOES> ( -- )  dup thislib ! proc: ;
   
 : init-shared-libs ( -- )  : init-shared-libs ( -- )
     defers 'cold  libs      defers 'cold
     0  libs  BEGIN  @ dup  WHILE  dup  REPEAT  drop      0  libs  BEGIN
     BEGIN  dup  WHILE  >r          @ dup WHILE
         r@ @lib              dup  REPEAT
         r@ 2 cells +  BEGIN  @ dup  WHILE  r@ over @proc  REPEAT      drop BEGIN
         drop rdrop          dup  WHILE
     REPEAT  drop ;              >r
               r@ @lib
               r@ 2 cells +  BEGIN
                   @ dup  WHILE
                       r@ over @proc  REPEAT
               drop rdrop
       REPEAT
       drop ;
   
 ' init-shared-libs IS 'cold  ' init-shared-libs IS 'cold
   
Line 112  DOES> ( -- )  dup thislib ! proc: ; Line 255  DOES> ( -- )  dup thislib ! proc: ;
   
 : rettype ( endxt startxt "name" -- )  : rettype ( endxt startxt "name" -- )
     Create 2,      Create 2,
   DOES>  decl, symbol, previous revarg off ;    DOES>  decl, ind-call @ 0= IF  symbol,  THEN
       previous revarg off ind-call off ;
   
   : func@ >body cell+ @ ;
   : func' ' func@ ;
   : [func'] postpone ['] postpone func@ ; immediate restrict
   
 also c-decl definitions  also c-decl definitions
   
Line 121  also c-decl definitions Line 269  also c-decl definitions
 ' av-int      ' av-int-r      ' >r  argtype int  ' av-int      ' av-int-r      ' >r  argtype int
 ' av-float    ' av-float-r    ' f>l argtype sf  ' av-float    ' av-float-r    ' f>l argtype sf
 ' av-double   ' av-double-r   ' f>l argtype df  ' av-double   ' av-double-r   ' f>l argtype df
 ' av-longlong ' av-longlong-r ' 2>r argtype llong  ' av-longlong ' av-longlong-r ' 2>r argtype dlong
 ' av-ptr      ' av-ptr-r      ' >r  argtype ptr  ' av-ptr      ' av-ptr-r      ' >r  argtype ptr
   
 ' av-call-void     ' av-start-void     rettype (void)  ' av-call-void     ' av-start-void     rettype (void)
 ' av-call-int      ' av-start-int      rettype (int)  ' av-call-int      ' av-start-int      rettype (int)
 ' av-call-float    ' av-start-float    rettype (sf)  ' av-call-float    ' av-start-float    rettype (sf)
 ' av-call-double   ' av-start-double   rettype (fp)  ' av-call-double   ' av-start-double   rettype (fp)
 ' av-call-longlong ' av-start-longlong rettype (llong)  ' av-call-longlong ' av-start-longlong rettype (dlong)
 ' av-call-ptr      ' av-start-ptr      rettype (ptr)  ' av-call-ptr      ' av-start-ptr      rettype (ptr)
   
   : (addr)  postpone EXIT drop symbol, previous revarg off ;
   
 previous definitions  previous definitions
   
 \ legacy support for old library interfaces  \ legacy support for old library interfaces
Line 188  also cb-decl definitions Line 338  also cb-decl definitions
 ' va-arg-int      Alias int  ' va-arg-int      Alias int
 ' va-arg-float    Alias sf  ' va-arg-float    Alias sf
 ' va-arg-double   Alias df  ' va-arg-double   Alias df
 ' va-arg-longlong Alias llong  ' va-arg-longlong Alias dlong
 ' va-arg-ptr      Alias ptr  ' va-arg-ptr      Alias ptr
   
 ' va-return-void     ' va-start-void     va-ret (void)  ' va-return-void     ' va-start-void     va-ret (void)
 ' va-return-int      ' va-start-int      va-ret (int)  ' va-return-int      ' va-start-int      va-ret (int)
 ' va-return-float    ' va-start-float    va-ret (sf)  ' va-return-float    ' va-start-float    va-ret (sf)
 ' va-return-double   ' va-start-double   va-ret (fp)  ' va-return-double   ' va-start-double   va-ret (fp)
 ' va-return-longlong ' va-start-longlong va-ret (llong)  ' va-return-longlong ' va-start-longlong va-ret (dlong)
 ' va-return-ptr      ' va-start-ptr      va-ret (ptr)  ' va-return-ptr      ' va-start-ptr      va-ret (ptr)
   
 previous definitions  previous definitions
   
 \ 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]      

Removed from v.1.6  
changed lines
  Added in v.1.27


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>