[BACK]Return to fflib.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/fflib.fs between versions 1.4 and 1.17

version 1.4, 2003/08/17 12:21:05 version 1.17, 2007/12/31 17:34:58
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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 63  Defer legacy-proc  ' noop IS legacy-proc Line 63  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 71  DOES> ( x1 .. xn -- r ) Line 76  DOES> ( x1 .. xn -- r )
 \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
         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 107  DOES> ( -- )  dup thislib ! proc: ; Line 119  DOES> ( -- )  dup thislib ! proc: ;
     r> compile,  postpone EXIT ;      r> compile,  postpone EXIT ;
   
 : symbol, ( "c-symbol" -- )  : symbol, ( "c-symbol" -- )
     here thisproc @ 2 cells + ! bl sword s,      here thisproc @ 2 cells + ! parse-name s,
     thislib @ thisproc @ @proc ;      thislib @ thisproc @ @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 ;
   
 also c-decl definitions  also c-decl definitions
   
Line 121  also c-decl definitions Line 134  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 203  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) lseek  
 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.4  
changed lines
  Added in v.1.17

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