141 lines
2.8 KiB
Forth
141 lines
2.8 KiB
Forth
\ tag: misc useful functions
|
|
\
|
|
\ Misc useful functions
|
|
\
|
|
\ Copyright (C) 2003 Samuel Rydh
|
|
\
|
|
\ See the file "COPYING" for further information about
|
|
\ the copyright and warranty status of this work.
|
|
\
|
|
|
|
\ compare c-string with (str len) pair
|
|
: comp0 ( cstr str len -- 0|-1|1 )
|
|
3dup
|
|
comp ?dup if >r 3drop r> exit then
|
|
nip + c@ 0<> if 1 else 0 then
|
|
;
|
|
|
|
\ returns 0 if the strings match
|
|
: strcmp ( str1 len1 str2 len2 -- 0|1 )
|
|
rot over <> if 3drop 1 exit then
|
|
comp if 1 else 0 then
|
|
;
|
|
|
|
: strchr ( str len char -- where|0 )
|
|
>r
|
|
begin
|
|
1- dup 0>=
|
|
while
|
|
( str len )
|
|
over c@ r@ = if r> 2drop exit then
|
|
swap 1+ swap
|
|
repeat
|
|
r> 3drop 0
|
|
;
|
|
|
|
: cstrlen ( cstr -- len )
|
|
dup
|
|
begin dup c@ while 1+ repeat
|
|
swap -
|
|
;
|
|
|
|
: strdup ( str len -- newstr len )
|
|
dup if
|
|
dup >r
|
|
dup alloc-mem dup >r swap move
|
|
r> r>
|
|
else
|
|
2drop 0 0
|
|
then
|
|
;
|
|
|
|
: dict-strdup ( str len -- dict-addr len )
|
|
dup here swap allot null-align
|
|
swap 2dup >r >r move r> r>
|
|
;
|
|
|
|
\ -----------------------------------------------------
|
|
\ string copy and cat variants
|
|
\ -----------------------------------------------------
|
|
|
|
: tmpstrcat ( addr2 len2 addr1 len1 tmpbuf -- buf len1+len2 tmpbuf+l1+l2 )
|
|
\ save return arguments
|
|
dup 2 pick + 4 pick + >r ( R: buf+l1+l2 )
|
|
over 4 pick + >r
|
|
dup >r
|
|
\ copy...
|
|
2dup + >r
|
|
swap move r> swap move
|
|
r> r> r>
|
|
;
|
|
|
|
: tmpstrcpy ( addr1 len1 tmpbuf -- tmpbuf len1 tmpbuf+len1 )
|
|
swap 2dup >r >r move
|
|
r> r> 2dup +
|
|
;
|
|
|
|
|
|
|
|
\ -----------------------------------------------------
|
|
\ number to string conversion
|
|
\ -----------------------------------------------------
|
|
|
|
: numtostr ( num buf -- buf len )
|
|
swap rdepth -rot
|
|
( rdepth buf num )
|
|
begin
|
|
base @ u/mod swap
|
|
\ dup 0< if base @ + then
|
|
dup a < if ascii 0 else ascii a a - then + >r
|
|
?dup 0=
|
|
until
|
|
|
|
rdepth rot - 0
|
|
( buf len cnt )
|
|
begin
|
|
r> over 4 pick + c!
|
|
1+ 2dup <=
|
|
until
|
|
drop
|
|
;
|
|
|
|
: tohexstr ( num buf -- buf len )
|
|
base @ hex -rot numtostr rot base !
|
|
;
|
|
|
|
: toudecstr ( num buf -- buf len )
|
|
base @ decimal -rot numtostr rot base !
|
|
;
|
|
|
|
: todecstr ( num buf -- buf len )
|
|
over 0< if
|
|
swap negate over ascii - over c! 1+
|
|
( buf num buf+1 )
|
|
toudecstr 1+ nip
|
|
else
|
|
toudecstr
|
|
then
|
|
;
|
|
|
|
|
|
\ -----------------------------------------------------
|
|
\ string to number conversion
|
|
\ -----------------------------------------------------
|
|
|
|
: parse-hex ( str len -- value )
|
|
base @ hex -rot $number if 0 then swap base !
|
|
;
|
|
|
|
|
|
\ -----------------------------------------------------
|
|
\ miscellaneous functions
|
|
\ -----------------------------------------------------
|
|
|
|
: rot13 ( c - c )
|
|
dup upc [char] A [char] M between if d# 13 + exit then
|
|
dup upc [char] N [char] Z between if d# 13 - then
|
|
;
|
|
|
|
: rot13-str ( str len -- newstr len )
|
|
strdup 2dup bounds ?do i c@ rot13 i c! loop
|
|
;
|