[gforth] / gforth / fflib.fs  

gforth: gforth/fflib.fs

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

version 1.1, Fri Aug 15 21:45:46 2003 UTC version 1.2, Sat Aug 16 19:46:11 2003 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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 22 
Line 22 
 Variable thisproc  Variable thisproc
 Variable thislib  Variable thislib
 \G links between libraries  \G links between libraries
   Variable revdec  revdec off
   \ turn revdec on to compile bigFORTH libraries
   
   Vocabulary c-decl
   Vocabulary cb-decl
   
 : @lib ( lib -- )  : @lib ( lib -- )
     \G obtains library handle      \G obtains library handle
Line 46 
Line 51 
   
 : 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
 DOES> ( x1 .. xn -- r )  DOES> ( x1 .. xn -- r )
     dup cell+ @ swap 3 cells + >r ;      dup cell+ @ swap 3 cells + >r ;
   
Line 72 
Line 77 
   
 ' init-shared-libs IS 'cold  ' init-shared-libs IS 'cold
   
 ' av-int AConstant int  
 ' av-float AConstant sf  
 ' av-double AConstant df  
 ' av-longlong AConstant llong  
 ' av-ptr AConstant ptr  
   
 Variable revdec  revdec off  
 \ turn revdec on to compile bigFORTH libraries  
   
 : rettype ( endxt startxt "name" -- )  : rettype ( endxt startxt "name" -- )
     create immediate 2,      create immediate 2,
   DOES>    DOES>
     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 drop
         BEGIN  r> dup  WHILE  compile,  REPEAT  drop          BEGIN  r> dup  WHILE  compile,  REPEAT  drop
     ELSE      ELSE
         BEGIN dup  WHILE  compile,  REPEAT  drop          BEGIN dup  WHILE  compile,  REPEAT  drop
     THEN      THEN
     r> compile,  postpone EXIT      r> compile,  postpone EXIT
     here thisproc @ 2 cells + ! bl sword s,      here thisproc @ 2 cells + ! bl sword s,
     thislib @ thisproc @ @proc ;      thislib @ thisproc @ @proc previous ;
   
   also c-decl definitions
   
   ' av-int AConstant int
   ' av-float AConstant sf
   ' av-double AConstant df
   ' av-longlong AConstant llong
   ' av-ptr AConstant 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 102 
Line 106 
 ' av-call-longlong ' av-start-longlong rettype (llong)  ' av-call-longlong ' av-start-longlong rettype (llong)
 ' av-call-ptr ' av-start-ptr rettype (ptr)  ' av-call-ptr ' av-start-ptr rettype (ptr)
   
 \ compatibility layer for old library -- use is deprecated  previous definitions
   
 Variable legacy  
   
 \ turn legacy on for old library  \ legacy interface for old library interface
   
 warnings @ warnings off  also c-decl
   
 : (int) ( n -- )  : (int...) ( n -- )
     legacy @ IF  
         >r ' execute r> 0 ?DO  int  LOOP          >r ' execute r> 0 ?DO  int  LOOP
     THEN  (int) ;      0 postpone Literal postpone ?DO postpone int postpone LOOP
 : (void) ( n -- )      postpone (int) ;
     legacy @ IF  : (void...) ( n -- )
         >r ' execute r> 0 ?DO  int  LOOP          >r ' execute r> 0 ?DO  int  LOOP
     THEN  (void) ;      0 postpone Literal postpone ?DO postpone int postpone LOOP
 : (float) ( n -- )      postpone (void) ;
     legacy @ IF  : (float...) ( n -- )
         >r ' execute r> 0 ?DO  df  LOOP          >r ' execute r> 0 ?DO  df  LOOP
     THEN  (df) ;      0 postpone Literal postpone ?DO postpone df postpone LOOP
       postpone (fp) ;
   : (int) ( n -- )
       >r ' execute r> 0 ?DO  int  LOOP  postpone (int) ;
   : (void) ( n -- )
       >r ' execute r> 0 ?DO  int  LOOP  postpone (void) ;
   : (float) ( n -- )
       >r ' execute r> 0 ?DO  df   LOOP  postpone (fp) ;
   
   previous
   
   \ 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 compile, 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 ;
   
   ' init-callbacks IS 'cold
   
   also cb-decl definitions
   
   \ arguments
   
 warnings on  ' va-arg-int      Alias int
   ' va-arg-float    Alias sf
   ' va-arg-double   Alias df
   ' va-arg-longlong Alias llong
   ' 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 (llong)
   ' va-return-ptr      ' va-start-ptr      va-ret (ptr)
   
   previous definitions
   
   \ testing stuff
   
 [ifdef] testing  [ifdef] testing
   
Line 140 
Line 198 
 libm fmodf sf sf (sf) fmodf  libm fmodf sf sf (sf) fmodf
 libm fmod  df df (fp) fmod  libm fmod  df df (fp) fmod
   
   callback wincall (int) int int int int callback;
   
   :noname ( a b c d -- e )  2drop 2drop 0 ; wincall do_timer
   
 [then]  [then]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help