[gforth] / gforth / fflib.fs  

gforth: gforth/fflib.fs

Diff for /gforth/fflib.fs between version 1.3 and 1.29

version 1.3, Sat Aug 16 21:09:47 2003 UTC version 1.29, Thu Dec 31 15:32:35 2009 UTC
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,2009 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 variables */
   \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
 Variable thisproc  Variable thisproc
 Variable thislib  Variable thislib
 \G links between libraries  
 Variable revdec  revdec off  Variable revdec  revdec off
 \ turn revdec on to compile bigFORTH libraries  \ turn revdec on to compile bigFORTH libraries
   Variable revarg  revarg off
   \ turn revarg on to compile declarations with reverse arguments
   Variable legacy  legacy off
   \ turn legacy on to compile bigFORTH legacy libraries
   
 Vocabulary c-decl  Vocabulary c-decl
 Vocabulary cb-decl  Vocabulary cb-decl
Line 49 
Line 185 
     swap 2 cells + dup @ A, !      swap 2 cells + dup @ A, !
     0 , 0 A, ;      0 , 0 A, ;
   
   Defer legacy-proc  ' noop IS legacy-proc
   
 : proc:  ( lib "name" -- )  : proc:  ( lib "name" -- )
     \G Creates a named proc stub      \G Creates a named proc stub
     Create proc, 0 also c-decl      Create proc, 0 also c-decl
       legacy @ IF  legacy-proc  THEN
 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 63 
Line 207 
     \G    linked list of library's procs      \G    linked list of library's procs
     \G    OS name of library as counted string      \G    OS name of library as counted string
     Create  here libs @ A, dup libs !      Create  here libs @ A, dup libs !
     0 , 0 A, bl sword string, @lib      0 , 0 A, parse-name string, @lib
 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
               dup  REPEAT
       drop BEGIN
           dup  WHILE
               >r
         r@ @lib          r@ @lib
         r@ 2 cells +  BEGIN  @ dup  WHILE  r@ over @proc  REPEAT              r@ 2 cells +  BEGIN
                   @ dup  WHILE
                       r@ over @proc  REPEAT
         drop rdrop          drop rdrop
     REPEAT  drop ;      REPEAT
       drop ;
   
 ' init-shared-libs IS 'cold  ' init-shared-libs IS 'cold
   
 : rettype ( endxt startxt "name" -- )  : argtype ( revxt pushxt fwxt "name" -- )
     create immediate 2,      Create , , , ;
   DOES>  
   : arg@ ( arg -- argxt pushxt )
       revarg @ IF  2 cells + @ ['] noop swap  ELSE  2@  THEN ;
   
   : arg, ( xt -- )
       dup ['] noop = IF  drop  EXIT  THEN  compile, ;
   
   : decl, ( 0 arg1 .. argn call start -- )
     2@ compile, >r      2@ compile, >r
     revdec @ IF  0 >r      revdec @ IF  0 >r
         BEGIN  dup  WHILE  >r  REPEAT drop          BEGIN  dup  WHILE  >r  REPEAT
         BEGIN  r> dup  WHILE  compile,  REPEAT  drop          BEGIN  r> dup  WHILE  arg@ arg,  REPEAT  drop
     ELSE          BEGIN  dup  WHILE  arg,  REPEAT drop
         BEGIN  dup  WHILE  compile,  REPEAT drop      ELSE  0 >r
           BEGIN  dup  WHILE  arg@ arg, >r REPEAT drop
           BEGIN  r> dup  WHILE  arg,  REPEAT  drop
     THEN      THEN
     r> compile,  postpone EXIT      r> compile,  postpone EXIT ;
     here thisproc @ 2 cells + ! bl sword s,  
     thislib @ thisproc @ @proc previous ;  : symbol, ( "c-symbol" -- )
       here thisproc @ 2 cells + ! parse-name s,
       thislib @ thisproc @ @proc ;
   
   : rettype ( endxt startxt "name" -- )
       Create 2,
     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
   
 ' av-int AConstant int  : <rev>  revarg on ;
 ' av-float AConstant sf  
 ' av-double AConstant df  ' av-int      ' av-int-r      ' >r  argtype int
 ' av-longlong AConstant llong  ' av-float    ' av-float-r    ' f>l argtype sf
 ' av-ptr AConstant ptr  ' av-double   ' av-double-r   ' f>l argtype df
   ' av-longlong ' av-longlong-r ' 2>r argtype dlong
   ' 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 interface for old library interface  \ legacy support for old library interfaces
   \ interface to old vararg stuff not implemented yet
   
 also c-decl  also c-decl
   
 : (int...) ( n -- )  :noname ( n 0 -- 0 int1 .. intn )
     >r ' execute r> 0 ?DO  int  LOOP      legacy @ 0< revarg !
     0 postpone Literal postpone ?DO postpone int postpone LOOP      swap 0 ?DO  int  LOOP  (int)
     postpone (int) ;  ; IS legacy-proc
 : (void...) ( n -- )  
     >r ' execute r> 0 ?DO  int  LOOP  
     0 postpone Literal postpone ?DO postpone int postpone LOOP  
     postpone (void) ;  
 : (float...) ( n -- )  
     >r ' execute r> 0 ?DO  df  LOOP  
     0 postpone Literal postpone ?DO postpone df postpone LOOP  
     postpone (fp) ;  
 : (int) ( n -- )  : (int) ( n -- )
     >r ' execute r> 0 ?DO  int  LOOP  postpone (int) ;      >r ' execute r> 0 ?DO  int  LOOP  (int) ;
 : (void) ( n -- )  : (void) ( n -- )
     >r ' execute r> 0 ?DO  int  LOOP  postpone (void) ;      >r ' execute r> 0 ?DO  int  LOOP  (void) ;
 : (float) ( n -- )  : (float) ( n -- )
     >r ' execute r> 0 ?DO  df   LOOP  postpone (fp) ;      >r ' execute r> 0 ?DO  df   LOOP  (fp) ;
   
 previous  previous
   
Line 169 
Line 338 
 ' 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 /lib/libc.so.6  
   
 libc sleep int (int) sleep  
 libc open  int int ptr (int) open  
 libc lseek int llong int (llong) lseek  
 libc read  int ptr int (int) read  
 libc close int (int) close  
   
 library libm /lib/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 av-int av-int av-call-int ;  
   
 \ 3 4 test  
   
 [then]  

Generate output suitable for use with a patch program
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.29
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help