Return to str-exec.fs CVS log

Up to [gforth] / gforth

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]