Annotation of gforth/contrib/strings.fs, revision 1.1
1.1 ! anton 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>