Annotation of gforth/str-exec.fs, revision 1.2
1.1 anton 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 )
1.2 ! anton 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.
1.1 anton 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:
1.2 ! anton 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:
1.1 anton 87: 0 [if]
88: \ tests
89: 5 ' . >string-execute dump
90: 5 5 ' .r >string-execute dump
91:
1.2 ! anton 92: : test 0 swap 0 do i . i + loop ;
1.1 anton 93:
1.2 ! anton 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 .
1.1 anton 96: cr
97: [endif]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>