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

Diff for /gforth/stuff.fs between versions 1.17 and 1.20

version 1.17, 2000/11/13 22:10:30 version 1.20, 2001/08/07 09:39:30
Line 75  AUser CSP Line 75  AUser CSP
 \ const-does>  \ const-does>
   
 : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive  : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive
       \ compile u literals, starting with the bottommost one
     ?dup-if      ?dup-if
         swap >r 1- compile-literals          swap >r 1- compile-literals
         r> POSTPONE literal          r> POSTPONE literal
     endif ;      endif ;
   
 : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive  : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive
       \ compile u fliterals, starting with the bottommost one
     ?dup-if      ?dup-if
         { F: r } 1- compile-fliterals          { F: r } 1- compile-fliterals
         r POSTPONE fliteral          r POSTPONE fliteral
     endif ;      endif ;
   
 : (const-does>) ( w*uw r*ur uw ur target "name" -- )  : (const-does>) ( w*uw r*ur uw ur target "name" -- )
       \ define a colon definition "name" containing w*uw r*ur as
       \ literals and a call to target.
     { uw ur target }      { uw ur target }
     header docol: cfa, \ start colon def without stack junk      header docol: cfa, \ start colon def without stack junk
     ur compile-fliterals uw compile-literals      ur compile-fliterals uw compile-literals
     target compile, POSTPONE exit reveal ;      target compile, POSTPONE exit reveal ;
   
 : const-does> ( run-time: w*uw r*ur uw ur "name" -- )  : const-does> ( run-time: w*uw r*ur uw ur "name" -- )
       \G Defines @var{name} and returns.@sp 0
       \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the
       \G code following the @code{const-does>}.
     here >r 0 POSTPONE literal      here >r 0 POSTPONE literal
     POSTPONE (const-does>)      POSTPONE (const-does>)
     POSTPONE ;      POSTPONE ;
     noname : POSTPONE rdrop      noname : POSTPONE rdrop
     lastxt r> cell+ ! \ patch the literal      lastxt r> cell+ ! \ patch the literal
 ; immediate  ; immediate
   
   \ !! rewrite slurp-file using slurp-fid
   : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
       \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents
       r/o bin open-file throw >r
       r@ file-size throw abort" file too large"
       dup allocate throw swap
       2dup r@ read-file throw over <> abort" could not read whole file"
       r> close-file throw ;
   
   : slurp-fid { fid -- addr u }
       \G @var{addr u} is the content of the file @var{fid}
       0 0 begin ( awhole uwhole )
           dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew )
           rot r@ fid read-file throw ( awhole uwhole uread R: unew )
           r> 2dup =
       while ( awhole uwhole uread unew )
           2drop
       repeat
       - + dup >r resize throw r> ;
Removed from v.1.17  
changed lines
  Added in v.1.20

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