[gforth] / gforth / fflib.fs  

gforth: gforth/fflib.fs

Diff for /gforth/fflib.fs between version 1.1 and 1.14

version 1.1, Fri Aug 15 21:45:46 2003 UTC version 1.14, Thu May 25 22:10:16 2006 UTC
Line 1 
Line 1 
 \ lib.fs        shared library support package          11may97py  \ lib.fs        shared library support package          16aug03py
   
 \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 19 
Line 19 
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 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
   \ 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 cb-decl
   
 : @lib ( lib -- )  : @lib ( lib -- )
     \G obtains library handle      \G obtains library handle
Line 44 
Line 54 
     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      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 58 
Line 76 
     \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 ( -- )
Line 72 
Line 90 
   
 ' init-shared-libs IS 'cold  ' init-shared-libs IS 'cold
   
 ' av-int AConstant int  : argtype ( revxt pushxt fwxt "name" -- )
 ' av-float AConstant sf      Create , , , ;
 ' av-double AConstant df  
 ' av-longlong AConstant llong  
 ' av-ptr AConstant ptr  
   
 Variable revdec  revdec off  : arg@ ( arg -- argxt pushxt )
 \ turn revdec on to compile bigFORTH libraries      revarg @ IF  2 cells + @ ['] noop swap  ELSE  2@  THEN ;
   
 : rettype ( endxt startxt "name" -- )  : arg, ( xt -- )
     create immediate 2,      dup ['] noop = IF  drop  EXIT  THEN  compile, ;
   DOES>  
   : decl, ( 0 arg1 .. argn call start -- )
     2@ compile, >r      2@ compile, >r
     revdec @ IF      revdec @ IF  0 >r
         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,  
   : symbol, ( "c-symbol" -- )
       here thisproc @ 2 cells + ! parse-name s,
     thislib @ thisproc @ @proc ;      thislib @ thisproc @ @proc ;
   
   : rettype ( endxt startxt "name" -- )
       Create 2,
     DOES>  decl, ind-call @ 0= IF  symbol,  THEN
       previous revarg off ind-call off ;
   
   also c-decl definitions
   
   : <rev>  revarg on ;
   
   ' av-int      ' av-int-r      ' >r  argtype int
   ' av-float    ' av-float-r    ' f>l argtype sf
   ' 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)
   
 \ compatibility layer for old library -- use is deprecated  : (addr)  postpone EXIT drop symbol, previous revarg off ;
   
   previous definitions
   
 Variable legacy  \ legacy support for old library interfaces
   \ interface to old vararg stuff not implemented yet
   
 \ turn legacy on for old library  also c-decl
   
 warnings @ warnings off  :noname ( n 0 -- 0 int1 .. intn )
       legacy @ 0< revarg !
       swap 0 ?DO  int  LOOP  (int)
   ; IS legacy-proc
   
 : (int) ( n -- )  : (int) ( n -- )
     legacy @ IF      >r ' execute r> 0 ?DO  int  LOOP  (int) ;
         >r ' execute r> 0 ?DO  int  LOOP  
     THEN  (int) ;  
 : (void) ( n -- )  : (void) ( n -- )
     legacy @ IF      >r ' execute r> 0 ?DO  int  LOOP  (void) ;
         >r ' execute r> 0 ?DO  int  LOOP  
     THEN  (void) ;  
 : (float) ( n -- )  : (float) ( n -- )
     legacy @ IF      >r ' execute r> 0 ?DO  df   LOOP  (fp) ;
         >r ' execute r> 0 ?DO  df  LOOP  
     THEN  (df) ;  
   
 warnings on  previous
   
 [ifdef] testing  \ callback stuff
   
   Variable callbacks
   \G link between callbacks
   
   : callback ( -- )
       Create  0 ] postpone >r also cb-decl
     DOES>
       Create here >r 0 , callbacks @ A, r@ callbacks !
       swap postpone Literal postpone call , postpone EXIT
       r> dup cell+ cell+ alloc-callback swap !
     DOES> @ ;
   
   : callback; ( 0 xt1 .. xtn -- )
       BEGIN  over  WHILE  compile,  REPEAT
       postpone r> postpone execute compile, drop
       postpone EXIT postpone [ previous ; immediate
   
   : va-ret ( xt xt -- )
       Create A, A, immediate
     DOES> 2@ compile, ;
   
   : init-callbacks ( -- )
       defers 'cold  callbacks 1 cells -
       BEGIN  cell+ @ dup  WHILE  dup cell+ cell+ alloc-callback over !
       REPEAT  drop ;
   
 library libc /lib/libc.so.6  ' init-callbacks IS 'cold
   
 libc sleep int (int) sleep  also cb-decl definitions
 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  \ arguments
   
 libm fmodf sf sf (sf) fmodf  ' va-arg-int      Alias int
 libm fmod  df df (fp) fmod  ' va-arg-float    Alias sf
   ' va-arg-double   Alias df
   ' va-arg-longlong Alias dlong
   ' va-arg-ptr      Alias ptr
   
   ' va-return-void     ' va-start-void     va-ret (void)
   ' va-return-int      ' va-start-int      va-ret (int)
   ' va-return-float    ' va-start-float    va-ret (sf)
   ' va-return-double   ' va-start-double   va-ret (fp)
   ' va-return-longlong ' va-start-longlong va-ret (dlong)
   ' va-return-ptr      ' va-start-ptr      va-ret (ptr)
   
 [then]  previous definitions

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help