version 1.1, 2000/03/26 21:53:16
|
version 1.16, 2012/08/17 22:24:27
|
Line 1
|
Line 1
|
\ dynamic string handling 10aug99py |
\ dynamic string handling 10aug99py |
|
|
: delete ( buffer size count -- ) |
\ Copyright (C) 2000,2005,2007,2010,2011 Free Software Foundation, Inc. |
over min >r r@ - ( left over ) dup 0> |
|
IF 2dup swap dup r@ + -rot swap move THEN + r> bl fill ; |
|
|
|
: insert ( string length buffer size -- ) |
|
rot over min >r r@ - ( left over ) |
|
over dup r@ + rot move r> move ; |
|
|
|
: $padding ( n -- n' ) |
|
[ 6 cells ] Literal + [ -4 cells ] Literal and ; |
|
: $! ( addr1 u addr2 -- ) |
|
dup @ IF dup @ free throw THEN |
|
over $padding allocate throw over ! @ |
|
over >r rot over cell+ r> move 2dup ! + cell+ bl swap c! ; |
|
: $@len ( addr -- u ) @ @ ; |
|
: $@ ( addr1 -- addr2 u ) @ dup cell+ swap @ ; |
|
: $!len ( u addr -- ) |
|
over $padding over @ swap resize throw over ! @ ! ; |
|
: $del ( addr off u -- ) >r >r dup $@ r> /string r@ delete |
|
dup $@len r> - swap $!len ; |
|
: $ins ( addr1 u addr2 off -- ) >r |
|
2dup dup $@len rot + swap $!len $@ 1+ r> /string insert ; |
|
: $+! ( addr1 u addr2 -- ) dup $@len $ins ; |
|
: $off ( addr -- ) dup @ free throw off ; |
|
|
|
\ dynamic string handling 12dec99py |
\ This file is part of Gforth. |
|
|
|
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation, either version 3 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program. If not, see http://www.gnu.org/licenses/. |
|
|
|
[IFUNDEF] $! |
|
: delete ( buffer size n -- ) \ gforth-string |
|
\G deletes the first @var{n} bytes from a buffer and fills the |
|
\G rest at the end with blanks. |
|
over min >r r@ - ( left over ) dup 0> |
|
IF 2dup swap dup r@ + -rot swap move THEN + r> bl fill ; |
|
|
|
: insert ( string length buffer size -- ) \ gforth-string |
|
\G inserts a string at the front of a buffer. The remaining |
|
\G bytes are moved on. |
|
rot over min >r r@ - ( left over ) |
|
over dup r@ + rot move r> move ; |
|
|
|
: $padding ( n -- n' ) \ gforth-string |
|
[ 6 cells ] Literal + [ -4 cells ] Literal and ; |
|
: $! ( addr1 u addr2 -- ) \ gforth-string string-store |
|
\G stores a string at an address, If there was a string there |
|
\G already, that string will be lost. |
|
dup @ IF dup @ free throw THEN |
|
over $padding allocate throw over ! @ |
|
over >r rot over cell+ r> move 2dup ! + cell+ bl swap c! ; |
|
: $@len ( addr -- u ) \ gforth-string string-fetch-len |
|
\G returns the length of the stored string. |
|
@ @ ; |
|
: $@ ( addr1 -- addr2 u ) \ gforth-string string-fetch |
|
\G returns the stored string. |
|
@ dup cell+ swap @ ; |
|
: $!len ( u addr -- ) \ gforth-string string-store-len |
|
\G changes the length of the stored string. Therefore we must |
|
\G change the memory area and adjust address and count cell as |
|
\G well. |
|
over $padding over @ swap resize throw over ! @ ! ; |
|
: $del ( addr off u -- ) \ gforth-string string-del |
|
\G deletes @var{u} bytes from a string with offset @var{off}. |
|
>r >r dup $@ r> /string r@ delete |
|
dup $@len r> - swap $!len ; |
|
: $ins ( addr1 u addr2 off -- ) \ gforth-string string-ins |
|
\G inserts a string at offset @var{off}. |
|
>r 2dup dup $@len rot + swap $!len $@ 1+ r> /string insert ; |
|
: $+! ( addr1 u addr2 -- ) \ gforth-string string-plus-store |
|
\G appends a string to another. |
|
dup $@len $ins ; |
|
: $off ( addr -- ) \ gforth-string string-off |
|
\G releases a string. |
|
dup @ dup IF free throw off ELSE 2drop THEN ; |
|
: $init ( addr -- ) \ gforth-string string-init |
|
\G initializes a string to empty (doesn't look at what was there before). |
|
>r r@ off s" " r> $! ; |
|
|
: $split ( addr u char -- addr1 u1 addr2 u2 ) |
\ dynamic string handling 12dec99py |
>r 2dup r> scan dup >r 1 /string 2swap r> - 2swap ; |
|
|
|
: $iter ( .. $addr char xt -- .. ) { char xt } |
: $split ( addr u char -- addr1 u1 addr2 u2 ) \ gforth-string string-split |
$@ BEGIN dup WHILE char $split >r >r xt execute r> r> |
\G divides a string into two, with one char as separator (e.g. '?' |
REPEAT 2drop ; |
\G for arguments in an HTML query) |
|
>r 2dup r> scan dup >r dup IF 1 /string THEN |
|
2swap r> - 2swap ; |
|
|
|
: $iter ( .. $addr char xt -- .. ) \ gforth-string string-iter |
|
\G takes a string apart piece for piece, also with a character as |
|
\G separator. For each part a passed token will be called. With |
|
\G this you can take apart arguments -- separated with '&' -- at |
|
\G ease. |
|
>r >r |
|
$@ BEGIN dup WHILE r@ $split i' -rot >r >r execute r> r> |
|
REPEAT 2drop rdrop rdrop ; |
|
|
|
\ string array words |
|
|
|
: $[] { n addr -- addr' } |
|
addr @ 0= IF s" " addr $! THEN |
|
addr $@ n cells /string |
|
dup cell < IF |
|
2drop addr $@len |
|
n 1+ cells addr $!len |
|
addr $@ rot /string erase |
|
addr $@ n cells /string |
|
THEN drop ; |
|
|
|
: $[]! ( addr u n $addr -- ) $[] $! ; |
|
: $[]+! ( addr u n $addr -- ) $[] $+! ; |
|
: $[]@ ( n $addr -- addr u ) $[] dup @ IF $@ ELSE drop s" " THEN ; |
|
|
|
: $over { addr u $addr off -- } |
|
\G overwrite string at offset off with addr u |
|
$addr @ 0= IF s" " $addr $! THEN |
|
$addr $@len u off + < IF |
|
$addr $@len dup |
|
u off + max $addr $!len |
|
$addr $@ rot /string bl fill |
|
THEN |
|
addr $addr $@ off /string u min move ; |
|
[THEN] |
|
|