Annotation of gforth/string.fs, revision 1.17
1.1 pazsan 1: \ dynamic string handling 10aug99py
2:
1.15 anton 3: \ Copyright (C) 2000,2005,2007,2010,2011 Free Software Foundation, Inc.
1.3 anton 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
1.7 anton 9: \ as published by the Free Software Foundation, either version 3
1.3 anton 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
1.7 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.3 anton 19:
1.14 pazsan 20: [IFUNDEF] $!
1.13 pazsan 21: : delete ( buffer size n -- ) \ gforth-string
22: \G deletes the first @var{n} bytes from a buffer and fills the
23: \G rest at the end with blanks.
24: over min >r r@ - ( left over ) dup 0>
25: IF 2dup swap dup r@ + -rot swap move THEN + r> bl fill ;
1.1 pazsan 26:
1.13 pazsan 27: : insert ( string length buffer size -- ) \ gforth-string
28: \G inserts a string at the front of a buffer. The remaining
29: \G bytes are moved on.
30: rot over min >r r@ - ( left over )
31: over dup r@ + rot move r> move ;
1.1 pazsan 32:
1.13 pazsan 33: : $padding ( n -- n' ) \ gforth-string
34: [ 6 cells ] Literal + [ -4 cells ] Literal and ;
35: : $! ( addr1 u addr2 -- ) \ gforth-string string-store
36: \G stores a string at an address, If there was a string there
37: \G already, that string will be lost.
38: dup @ IF dup @ free throw THEN
39: over $padding allocate throw over ! @
40: over >r rot over cell+ r> move 2dup ! + cell+ bl swap c! ;
41: : $@len ( addr -- u ) \ gforth-string string-fetch-len
42: \G returns the length of the stored string.
43: @ @ ;
44: : $@ ( addr1 -- addr2 u ) \ gforth-string string-fetch
45: \G returns the stored string.
46: @ dup cell+ swap @ ;
47: : $!len ( u addr -- ) \ gforth-string string-store-len
48: \G changes the length of the stored string. Therefore we must
49: \G change the memory area and adjust address and count cell as
50: \G well.
51: over $padding over @ swap resize throw over ! @ ! ;
52: : $del ( addr off u -- ) \ gforth-string string-del
53: \G deletes @var{u} bytes from a string with offset @var{off}.
54: >r >r dup $@ r> /string r@ delete
55: dup $@len r> - swap $!len ;
56: : $ins ( addr1 u addr2 off -- ) \ gforth-string string-ins
57: \G inserts a string at offset @var{off}.
58: >r 2dup dup $@len rot + swap $!len $@ 1+ r> /string insert ;
59: : $+! ( addr1 u addr2 -- ) \ gforth-string string-plus-store
60: \G appends a string to another.
61: dup $@len $ins ;
62: : $off ( addr -- ) \ gforth-string string-off
63: \G releases a string.
64: dup @ dup IF free throw off ELSE 2drop THEN ;
65: : $init ( addr -- ) \ gforth-string string-init
66: \G initializes a string to empty (doesn't look at what was there before).
67: >r r@ off s" " r> $! ;
1.1 pazsan 68:
69: \ dynamic string handling 12dec99py
70:
1.13 pazsan 71: : $split ( addr u char -- addr1 u1 addr2 u2 ) \ gforth-string string-split
72: \G divides a string into two, with one char as separator (e.g. '?'
73: \G for arguments in an HTML query)
74: >r 2dup r> scan dup >r dup IF 1 /string THEN
75: 2swap r> - 2swap ;
1.1 pazsan 76:
1.13 pazsan 77: : $iter ( .. $addr char xt -- .. ) \ gforth-string string-iter
78: \G takes a string apart piece for piece, also with a character as
79: \G separator. For each part a passed token will be called. With
80: \G this you can take apart arguments -- separated with '&' -- at
81: \G ease.
82: >r >r
83: $@ BEGIN dup WHILE r@ $split i' -rot >r >r execute r> r>
84: REPEAT 2drop rdrop rdrop ;
1.16 pazsan 85:
86: \ string array words
87:
1.17 ! pazsan 88: : $[] ( n addr -- addr' ) >r
! 89: r@ @ 0= IF s" " r@ $! THEN
! 90: r@ $@ 2 pick cells /string
1.16 pazsan 91: dup cell < IF
1.17 ! pazsan 92: 2drop r@ $@len
! 93: over 1+ cells r@ $!len
! 94: r@ $@ rot /string 0 fill
! 95: r@ $@ 2 pick cells /string
! 96: THEN drop nip rdrop ;
1.16 pazsan 97:
98: : $[]! ( addr u n $addr -- ) $[] $! ;
99: : $[]+! ( addr u n $addr -- ) $[] $+! ;
100: : $[]@ ( n $addr -- addr u ) $[] dup @ IF $@ ELSE drop s" " THEN ;
101:
1.17 ! pazsan 102: : $over ( addr u $addr off -- )
1.16 pazsan 103: \G overwrite string at offset off with addr u
1.17 ! pazsan 104: swap >r
! 105: r@ @ 0= IF s" " r@ $! THEN
! 106: 2dup + r@ $@len > IF
! 107: 2dup + r@ $@len tuck max r@ $!len
! 108: r@ $@ rot /string bl fill
1.16 pazsan 109: THEN
1.17 ! pazsan 110: r> $@ rot /string rot min move ;
1.14 pazsan 111: [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>