1: \ strings.fs
2: \
3: \ Gforth Version of the kForth string utility words
4: \
5: \ Copyright (c) 1999--2004 Krishna Myneni
6: \
7: \ This software is provided under the terms of the
8: \ GNU General Public License.
9: \
10: \ Revisions:
11: \
12: \ 03-24-1999 created km
13: \ 03-25-1999 added number to string conversions km
14: \ 08-12-1999 fixed f>string km
15: \ 10-11-1999 added blank km
16: \ 12-12-1999 fixed f>string for zero case km
17: \ 12-22-1999 added -trailing, scan, and skip km
18: \ 01-23-2000 replaced char with [char] for ANS Forth compatibility km
19: \ 06-16-2000 added isdigit and modified string>s and string>f km
20: \ 09-02-2000 fixed u>string to work over full range km
21: \ 07-12-2001 used built-in Forth words <# #s #> for conversions,
22: \ added ud>string and d>string. f>string now can handle
23: \ decimal places greater than 8 km
24: \ 09-21-2001 changed occurences of DO to ?DO km
25: \ 10-02-2001 added parse_args km
26: \ 10-10-2001 fixed problem with f>string when number is 0e km
27: \ 10-15-2001 added /STRING km
28: \ 03-28-2002 added SEARCH, PARSE_TOKEN, PARSE_LINE, IS_LC_ALPHA km
29: \ 07-31-2002 added SLITERAL; removed SEARCH since SEARCH and
30: \ COMPARE are now part of kForth km
31: \ 04-12-2003 ported to PFE, gforth. removed defs of intrinsic words,
32: \ recoded for separate fp stack km
33:
34: : parse_token ( a u -- a2 u2 a3 u3)
35: \ parse next token from the string; a3 u3 is the token string
36: BL SKIP 2DUP BL SCAN 2>R R@ - 2R> 2SWAP ;
37:
38: : parse_line ( a u -- a1 u1 a2 u2 ... n )
39: ( -trailing)
40: 0 >r
41: begin
42: parse_token
43: dup
44: while
45: r> 1+ >r
46: 2swap
47: repeat
48: 2drop 2drop r> ;
49:
50: : is_lc_alpha ( n -- flag | true if n is a lower case alphabetical character)
51: DUP 96 > SWAP 123 < AND ;
52:
53: : isdigit ( n -- flag | return true if n is ascii value of '0' through '9' )
54: dup [char] / > swap [char] : < and ;
55:
56: : strcpy ( ^str addr -- | copy a counted string to addr )
57: >r dup c@ 1+ r> swap cmove ;
58:
59: : strlen ( addr -- len | determine length of a null terminated string )
60: \ This word is not intended for use on counted strings;
61: \ Use "count" to obtain the length of a counted string.
62: 0
63: begin
64: over c@ 0= dup invert if -rot 1+ swap 1+ swap rot then
65: until
66: nip ;
67:
68:
69: 16384 constant STR_BUF_SIZE
70: create string_buf STR_BUF_SIZE allot \ dynamic string buffer
71: variable str_buf_ptr
72: string_buf str_buf_ptr !
73:
74: : adjust_str_buf_ptr ( u -- | adjust pointer to accomodate u bytes )
75: str_buf_ptr @ swap +
76: string_buf STR_BUF_SIZE + >=
77: if
78: string_buf str_buf_ptr ! \ wrap pointer
79: then ;
80:
81: : strbufcpy ( ^str1 -- ^str2 | copy a counted string to the dynamic string buffer )
82: dup c@ 1+ dup adjust_str_buf_ptr
83: swap str_buf_ptr @ strcpy
84: str_buf_ptr @ dup rot + str_buf_ptr ! ;
85:
86: : strcat ( addr1 u1 addr2 u2 -- addr3 u3 )
87: rot 2dup + 1+ adjust_str_buf_ptr
88: -rot
89: 2swap dup >r
90: str_buf_ptr @ swap cmove
91: str_buf_ptr @ r@ +
92: swap dup r> + >r
93: cmove
94: str_buf_ptr @
95: dup r@ + 0 swap c!
96: dup r@ + 1+ str_buf_ptr !
97: r> ;
98:
99: : strpck ( addr u -- ^str | create counted string )
100: 255 min dup 1+ adjust_str_buf_ptr
101: dup str_buf_ptr @ c!
102: tuck str_buf_ptr @ 1+ swap cmove
103: str_buf_ptr @ over + 1+ 0 swap c!
104: str_buf_ptr @
105: dup rot 1+ + str_buf_ptr ! ;
106:
107: \
108: \ Base 10 number to string conversions and vice-versa
109: \
110:
111: 32 constant NUMBER_BUF_LEN
112: create number_buf NUMBER_BUF_LEN allot
113:
114: create fnumber_buf 64 allot
115: variable number_sign
116: variable number_val
117: variable fnumber_sign
118: fvariable fnumber_val
119: fvariable fnumber_divisor
120: variable fnumber_power
121: variable fnumber_digits
122: variable fnumber_whole_part
123:
124: variable number_count
125:
126: : u>string ( u -- ^str | create counted string to represent u in base 10 )
127: base @ swap decimal 0 <# #s #> strpck swap base ! ;
128:
129: : ud>string ( ud -- ^str | create counted string to represent ud in base 10 )
130: base @ >r decimal <# #s #> strpck r> base ! ;
131:
132: : d>string ( d -- ^str | create counted string to represent d in base 10 )
133: dup >r dabs ud>string r> 0< if s" -" rot count strcat strpck then ;
134:
135: : s>string ( n -- ^str | create counted string to represent n in base 10 )
136: dup >r abs u>string
137: r> 0< if
138: s" -" rot count strcat strpck
139: then ;
140:
141: : string>s ( ^str -- n | always interpret in base 10 )
142: 0 number_val !
143: false number_sign !
144: count
145: 0 ?do
146: dup c@
147: case
148: [char] - of true number_sign ! endof
149: [char] + of false number_sign ! endof
150: dup isdigit
151: if
152: dup [char] 0 - number_val @ 10 * + number_val !
153: then
154: endcase
155: 1+
156: loop
157: drop
158: number_val @ number_sign @ if negate then ;
159:
160: \ conversion is in exponential format with n places
161:
162: : f>string ( n -- ^str ) ( F: f -- )
163: fdup f0=
164: if
165: f>d <# rot 0 ?do # loop #> s" e0" strcat
166: s" 0." 2swap strcat strpck exit
167: then
168: dup 16 swap u< if drop fdrop c" ******" exit then \ test for invalid n
169: fnumber_digits !
170: 0 fnumber_power !
171: fdup 0e f< fnumber_sign !
172: fabs
173: fdup 1e f<
174: if
175: fdup 0e f>
176: if
177: begin
178: 10e f* -1 fnumber_power +!
179: fdup 1e f>=
180: until
181: then
182: else
183: fdup
184: 10e f>=
185: if
186: begin
187: 10e f/ 1 fnumber_power +!
188: fdup 10e f<
189: until
190: then
191: then
192: 10e fnumber_digits @ ( s>f) s>d d>f f**
193: f* floor f>d d>string
194: count drop dup fnumber_buf
195: fnumber_sign @
196: if [char] - else bl then
197: swap c!
198: fnumber_buf 1+ 1 cmove
199: 1+
200: [char] . fnumber_buf 2 + c!
201: fnumber_buf 3 + fnumber_digits @ cmove
202: fnumber_buf fnumber_digits @ 3 +
203: s" e" strcat
204: fnumber_power @ s>string count strcat
205: strpck ;
206:
207:
208: : string>f ( ^str -- f )
209: true fnumber_whole_part !
210: 0e fnumber_val f!
211: 1e fnumber_divisor f!
212: false fnumber_sign !
213: count 2dup + 1- nip swap
214: begin
215: dup c@
216: case
217: [char] - of true fnumber_sign ! endof
218: [char] + of false fnumber_sign ! endof
219: [char] . of false fnumber_whole_part ! endof
220: dup isdigit
221: if
222: dup [char] 0 - ( s>f) s>d d>f
223: fnumber_whole_part @
224: if
225: fnumber_val f@ 10e f*
226: else
227: fnumber_divisor f@ 10e f*
228: fdup fnumber_divisor f!
229: f/ fnumber_val f@
230: then
231: f+ fnumber_val f!
232: else
233: dup dup [char] E = swap [char] e = or
234: if
235: drop 2dup
236: -
237: dup 0>
238: if
239: number_buf c!
240: dup 1+ number_buf 1+ number_buf c@ cmove
241: 2drop
242: number_buf string>s ( s>f) s>d d>f 10e fswap f**
243: else
244: drop 2drop 1e
245: then
246: fnumber_val f@ f* fnumber_sign @ if fnegate then
247: exit
248: then
249: then
250: endcase
251: 1+ 2dup <
252: until
253: 2drop
254: fnumber_val f@
255: fnumber_sign @ if fnegate then ;
256:
257:
258: \ parse a string delimited by spaces into fp args
259:
260: : parse_args ( a u -- n ) ( F: -- f1 ... fn )
261: 0 >r
262: begin
263: dup 0>
264: while
265: bl skip
266: 2dup
267: bl scan 2>r
268: r@ - dup 0=
269: if drop r> 0 >r then
270: strpck string>f
271: 2r> r>
272: 1+ >r
273: repeat
274: 2drop r> ;
275:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to strings.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / contrib