blob: be774910aad741272bb71bbaddbcf61df09fe606 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
\ 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 ints "hi,...,lo" separated by comma
: parse-ints ( str len num -- val.lo .. val.hi )
-rot 2 pick -rot
begin
rot 1- -rot 2 pick 0>=
while
( num n str len )
2dup ascii , strchr ?dup if
( num n str len p )
1+ -rot
2 pick 2 pick - ( num n p str len len1+1 )
dup -rot - ( num n p str len1+1 len2 )
-rot 1- ( num n p len2 str len1 )
else
0 0 2swap
then
$number if 0 then >r
repeat
3drop
( num )
begin 1- dup 0>= while r> swap repeat
drop
;
: parse-2int ( str len -- val.lo val.hi )
2 parse-ints
;
: parse-nhex ( str len num -- values )
base @ >r hex parse-ints r> base !
;
: parse-hex ( str len -- value )
1 parse-nhex
;
\ -----------------------------------------------------
\ 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
;
|
