Diff for /gforth/stuff.fs between versions 1.16 and 1.19

version 1.16, 2000/09/23 15:46:59 version 1.19, 2001/01/19 21:07:05
Line 18 Line 18
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   require glocals.fs
   
 ' require alias needs ( ... "name" -- ... ) \ gforth  ' require alias needs ( ... "name" -- ... ) \ gforth
 \G An alias for @code{require}; exists on other systems (e.g., Win32Forth).  \G An alias for @code{require}; exists on other systems (e.g., Win32Forth).
Line 70  AUser CSP Line 71  AUser CSP
   
 : in-return-stack? ( addr -- f )  : in-return-stack? ( addr -- f )
     rp0 @ swap - [ forthstart 6 cells + ]L @ u< ;      rp0 @ swap - [ forthstart 6 cells + ]L @ u< ;
   
   \ const-does>
   
   : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive
       \ compile u literals, starting with the bottommost one
       ?dup-if
           swap >r 1- compile-literals
           r> POSTPONE literal
       endif ;
   
   : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive
       \ compile u fliterals, starting with the bottommost one
       ?dup-if
           { F: r } 1- compile-fliterals
           r POSTPONE fliteral
       endif ;
   
   : (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 }
       header docol: cfa, \ start colon def without stack junk
       ur compile-fliterals uw compile-literals
       target compile, POSTPONE exit reveal ;
   
   : 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
       POSTPONE (const-does>)
       POSTPONE ;
       noname : POSTPONE rdrop
       lastxt r> cell+ ! \ patch the literal
   ; immediate
   
   : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
       \ c-addr1 u1 is the filename, 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 ;
   

Removed from v.1.16  
changed lines
  Added in v.1.19


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