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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
# 23apr11abu
# (c) Software Lab. Alexander Burger
(data 'ExtData)
initData
### Soundex Algorithm ###
(data 'SnxTab)
bytes (
(char "0") (char "1") (char "2") (char "3") (char "4") (char "5") (char "6") (char "7") # 48
(char "8") (char "9") 0 0 0 0 0 0
0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 64
0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0
(char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F")
(char "S") 0 (char "S") 0 0 0 0 0
0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 96
0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0
(char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F")
(char "S") 0 (char "S") 0 0 0 0 0
0 0 0 0 0 0 0 0 # 128
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 # 160
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 (char "S") # 192
0 0 0 0 0 0 0 0
(char "T") (char "N") 0 0 0 0 0 (char "S")
0 0 0 0 0 0 0 (char "S")
0 0 0 0 0 0 0 (char "S") # 224
0 0 0 0 0 0 0 0
0 (char "N") )
(equ SNXBASE 48)
(equ SNXSIZE (+ (* 24 8) 2))
(code 'ExtCode)
initCode
# (ext:Snx 'any ['cnt]) -> sym
(code 'Snx 2)
push X
push Y
ld X E
ld Y (E CDR) # Y on args
call evSymY_E # Eval 'any'
cmp E Nil
if ne # No
ld E (E TAIL)
call nameE_E # Get name
link
push E # <L II> Save Name
link
ld Y (Y CDR) # Next arg
atom Y # Any?
ldnz E 24 # Default to 24
if z # Yes
call evCntXY_FE # Eval 'cnt'
end
tuck ZERO # <L I> Result
ld X S
link
push 4 # <S II> Build name
push X # <S I> Pack status
ld X (L II) # Get name
ld C 0 # Index
do
call symCharCX_FACX # First char?
jz 90 # No
cmp A SNXBASE # Too small?
until ge # No
cmp A (char "a") # Lower case?
if ge
cmp A (char "z")
jle 40 # Yes
end
cmp A 128
jeq 40 # Yes
cmp A 224
if ge
cmp A 255
if le # Yes
40 off B 32 # Convert to lower case
end
end
push A # <S> Last character
xchg C (S II) # Swap status
xchg X (S I)
call charSymACX_CX # Pack first char
xchg X (S I) # Swap status
xchg C (S II)
do
call symCharCX_FACX # Next char?
while nz # Yes
cmp A 32 # Non-white?
if gt # Yes
sub A SNXBASE # Too small?
jlt 60 # Yes
cmp A SNXSIZE # Too big?
jge 60 # Yes
ld B (A SnxTab) # Character entry?
zxt
or A A
if z # No
60 ld (S) 0 # Clear last character
else
cmp A (S) # Same as last?
if ne # No
dec E # Decrement count
break z
ld (S) A # Save last character
xchg C (S II) # Swap status
xchg X (S I)
call charSymACX_CX # Pack char
xchg X (S I) # Swap status
xchg C (S II)
end
end
end
loop
90 ld X (L I) # Get result
call consSymX_E # Make transient symbol
drop
end
pop Y
pop X
ret
(equ BIAS 132)
(equ CLIP (- 32767 BIAS))
# (ext:Ulaw 'cnt) -> cnt # SEEEMMMM
(code 'Ulaw 2)
push X
ld X E
ld E ((E CDR)) # Get arg
eval # Eval 'cnt'
cnt E # # Short number?
jz cntErrEX # No
ld X 0 # No sign
shr E 4 # Normalize
if c # Negative?
ld X (hex "80") # Set sign
end
cmp E (+ CLIP 1) # Clip the value
ldnc E CLIP
add E BIAS # Increment by BIAS
ld A E # Double value
add A A # in 'tmp'
ld C 7 # Exponent
do
test A (hex "8000")
while z
add A A # Double 'tmp'
dec C # Decrement exponent
until z
ld A C # Get exponent
add A 3 # plus 3
shr E A # Shift value right
and E 15 # Lowest 4 bits
shl C 4 # Shift exponent left
or E C # Combine with value
or E X # and sign
not E # Negate
and E (hex "FF") # Get byte value
shl E 4 # Make short number
or E CNT
pop X
ret
### Base64 Encoding ###
(data 'Chr64)
ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
# (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg
(code 'Base64 2)
push X
push Y
push Z
ld X E
ld Y (E CDR) # Y on args
ld E (Y) # Eval first 'num|NIL'
eval
cmp E Nil # NIL?
if ne # No
shr E 4 # Normalize first arg
ld Z E # Keep in Z
shr E 2 # Upper 6 bits
call chr64E # Output encoded
ld Y (Y CDR) # Next arg
ld E (Y)
eval # Eval second arg
cmp E Nil # NIL?
if eq # Yes
ld E Z # Get first arg
and E 3 # Mask
shl E 4 # Shift to upper position
call chr64E # Output encoded
ld B (char "=") # and two equal signs
call (PutB)
ld B (char "=")
call (PutB)
ld E Nil # Return NIL
else
shr E 4 # Normalize second arg
and Z 3 # Mask first arg
shl Z 4 # Shift to upper position
ld A E # Get second arg
shr A 4 # Normalize
or A Z # Combine
ld Z E # Keep second arg in Z
call chr64A # Output encoded
ld Y (Y CDR) # Next arg
ld E (Y)
eval # Eval third arg
cmp E Nil # NIL?
if eq # Yes
ld A Z # Get second
and A 15 # Lowest four bits
shl A 2 # Shift
call chr64A # Output encoded
ld B (char "=") # and an equal sign
call (PutB)
ld E Nil # Return NIL
else
shr E 4 # Normalize third arg
ld A E
shr A 6 # Upper bits
and Z 15 # Lowest four bits of second arg
shl Z 2 # Shift
or A Z # Combine
call chr64A # Output encoded
and E 63 # Last arg
call chr64E # Output encoded
ld E TSym # Return T
end
end
end
pop Z
pop Y
pop X
ret
(code 'chr64E)
ld A E
(code 'chr64A)
ld B (A Chr64) # Fetch from table
jmp (PutB) # Output byte
# vi:et:ts=3:sw=3
|
