Annotation of gforth/str-exec.fs, revision 1.1
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 )
! 41: \ execute xt while the standard output (TYPE, EMIT, and everything
! 42: \ that uses them) is redirected to a string. The resulting string
! 43: \ is addr u, which is in ALLOCATEd memory; it is the
! 44: \ responsibility of the caller of >STRING-EXECUTE to FREE this
! 45: \ 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: 0 [if]
! 65: \ tests
! 66: 5 ' . >string-execute dump
! 67: 5 5 ' .r >string-execute dump
! 68:
! 69: : test 0 do i . loop ;
! 70:
! 71: cr 20 ' test >string-execute .s cr 2dup type drop free throw
! 72: cr 120 ' test >string-execute .s cr 2dup type drop free throw
! 73: cr
! 74: [endif]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>