[gforth] / gforth / fflib.fs  

gforth: gforth/fflib.fs

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

version 1.3, Sat Aug 16 21:09:47 2003 UTC version 1.4, Sun Aug 17 12:21:05 2003 UTC
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  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 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 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 ;
   
Line 77 
Line 85 
   
 ' 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 ;
   
   : symbol, ( "c-symbol" -- )
     here thisproc @ 2 cells + ! bl sword s,      here thisproc @ 2 cells + ! bl sword s,
     thislib @ thisproc @ @proc previous ;      thislib @ thisproc @ @proc ;
   
   : rettype ( endxt startxt "name" -- )
       Create 2,
     DOES>  decl, symbol, previous revarg off ;
   
 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 llong
   ' 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)
Line 108 
Line 133 
   
 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 185 
Line 204 
   
 [ifdef] testing  [ifdef] testing
   
 library libc /lib/libc.so.6  library libc libc.so.6
   
 libc sleep int (int) sleep  libc sleep int (int) sleep
 libc open  int int ptr (int) open  libc open  int int ptr (int) open
Line 193 
Line 212 
 libc read  int ptr int (int) read  libc read  int ptr int (int) read
 libc close int (int) close  libc close int (int) close
   
 library libm /lib/libm.so.6  library libm libm.so.6
   
 libm fmodf sf sf (sf) fmodf  libm fmodf sf sf (sf) fmodf
 libm fmod  df df (fp) fmod  libm fmod  df df (fp) fmod
Line 214 
Line 233 
     cr ." result " + .s cr ;      cr ." result " + .s cr ;
 ' cb-test 2:1 c_plus  ' cb-test 2:1 c_plus
   
 : test  c_plus av-start-int av-int av-int av-call-int ;  : test  c_plus av-start-int >r >r av-int-r av-int-r av-call-int ;
   
 \ 3 4 test  \ 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]  [then]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help