Return to str-exec.fs CVS log

Up to [gforth] / gforth

documentation changes

    1: \ >STRING-EXECUTE >BUFFER-EXECUTE
    2: \
    3: \ Copyright (C) 2011 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: 32 constant >string-initial-buflen
   21: 
   22: 2variable >string-buffer \ buffer
   23: variable  >string-len    \ actual string length
   24: 
   25: : >string-type { c-addr u -- }
   26:     >string-len @ { str-len }
   27:     str-len u + { new-str-len }
   28:     >string-buffer 2@
   29:     begin { buf-addr buf-size }
   30: 	new-str-len buf-size > while
   31: 	    buf-size 2* buf-addr over resize throw swap
   32: 	    2dup >string-buffer 2!
   33:     repeat 
   34:     c-addr buf-addr str-len + u move
   35:     new-str-len >string-len ! ;
   36: 
   37: : >string-emit { c^ c -- }
   38:     c 1 >string-type ;
   39: 
   40: : >string-execute ( ... xt -- ... addr u )
   41:     \G execute xt while the standard output (TYPE, EMIT, and everything
   42:     \G that uses them) is redirected to a string.  The resulting string
   43:     \G is addr u, which is in ALLOCATEd memory; it is the
   44:     \G responsibility of the caller of >STRING-EXECUTE to FREE this
   45:     \G string.
   46:     >string-buffer 2@ >string-len @
   47:     action-of type action-of emit    { d: oldbuf oldlen oldtype oldemit }
   48:     try
   49: 	>string-initial-buflen dup allocate throw swap >string-buffer 2!
   50: 	0 >string-len !
   51: 	['] >string-type is type
   52: 	['] >string-emit is emit
   53: 	execute
   54: 	>string-buffer 2@ drop >string-len @ tuck resize throw swap
   55: 	0 \ throw ball
   56:     restore
   57: 	oldbuf >string-buffer 2!
   58: 	oldlen >string-len !
   59: 	oldtype is type
   60: 	oldemit is emit
   61:     endtry
   62:     throw ;
   63: 
   64: \ altenative interface (for systems without memory allocation wordset):
   65: 
   66: \ >buffer-execute ( ... c-addr u1 xt -- ... u2 ) execute xt while the
   67: \ standard output (TYPE, EMIT, and everything that uses them) is
   68: \ redirected to the buffer c-addr u.  u2 is the number of characters
   69: \ that were output with TYPE or EMIT.  If u2<=u1, then the string
   70: \ c-addr u2 contains the output, otherwise c-addr u1 contains the
   71: \ first u1 characters of the output, and the other characters are not
   72: \ stored.
   73: 
   74: \ You can emulate >STRING-EXECUTE with >BUFFER-EXECUTE like this:
   75: \ Instead of
   76: 
   77: \ ... ['] foo >string-execute ( c-addr u ) ...
   78: 
   79: \ where FOO has the stack effect ( x1 x2 -- x3 ), write
   80: 
   81: \ ... 2dup 2>r (or whatever is necessary to save FOO's input operands)
   82: \ pad 0 ['] foo >buffer-execute >r drop ( throw away result of FOO )
   83: \ 2r> ( restore FOO's input operands )
   84: \ r@ allocate throw r> 2dup 2>r ['] foo >buffer-execute drop 2r>
   85: 
   86: 
   87: 0 [if]
   88: \ tests
   89: 5 ' . >string-execute dump
   90: 5 5 ' .r >string-execute dump
   91: 
   92: : test 0 swap 0 do i . i + loop ;
   93: 
   94: cr  20 ' test >string-execute .s cr 2dup type drop free throw .
   95: cr 120 ' test >string-execute .s cr 2dup type drop free throw .
   96: cr
   97: [endif]