ext.l (8052B)
1 # 18feb13abu 2 # (c) Software Lab. Alexander Burger 3 4 (data 'ExtData) 5 initData 6 7 ### Soundex Algorithm ### 8 (data 'SnxTab) 9 bytes ( 10 (char "0") (char "1") (char "2") (char "3") (char "4") (char "5") (char "6") (char "7") # 48 11 (char "8") (char "9") 0 0 0 0 0 0 12 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 64 13 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 14 (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") 15 (char "S") 0 (char "S") 0 0 0 0 0 16 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 96 17 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 18 (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") 19 (char "S") 0 (char "S") 0 0 0 0 0 20 0 0 0 0 0 0 0 0 # 128 21 0 0 0 0 0 0 0 0 22 0 0 0 0 0 0 0 0 23 0 0 0 0 0 0 0 0 24 0 0 0 0 0 0 0 0 # 160 25 0 0 0 0 0 0 0 0 26 0 0 0 0 0 0 0 0 27 0 0 0 0 0 0 0 0 28 0 0 0 0 0 0 0 (char "S") # 192 29 0 0 0 0 0 0 0 0 30 (char "T") (char "N") 0 0 0 0 0 (char "S") 31 0 0 0 0 0 0 0 (char "S") 32 0 0 0 0 0 0 0 (char "S") # 224 33 0 0 0 0 0 0 0 0 34 0 (char "N") ) 35 36 (equ SNXBASE 48) 37 (equ SNXSIZE (+ (* 24 8) 2)) 38 39 (code 'ExtCode) 40 initCode 41 42 # (ext:Snx 'any ['cnt]) -> sym 43 (code 'Snx 2) 44 push X 45 push Y 46 ld X E 47 ld Y (E CDR) # Y on args 48 call evSymY_E # Eval 'any' 49 cmp E Nil 50 if ne # No 51 ld E (E TAIL) 52 call nameE_E # Get name 53 link 54 push E # <L II> Save Name 55 link 56 ld Y (Y CDR) # Next arg 57 atom Y # Any? 58 ldnz E 24 # Default to 24 59 if z # Yes 60 call evCntXY_FE # Eval 'cnt' 61 end 62 tuck ZERO # <L I> Result 63 ld X S 64 link 65 push 4 # <S II> Build name 66 push X # <S I> Pack status 67 ld X (L II) # Get name 68 ld C 0 # Index 69 do 70 call symCharCX_FACX # First char? 71 jz 90 # No 72 cmp A SNXBASE # Too small? 73 until ge # No 74 cmp A (char "a") # Lower case? 75 if ge 76 cmp A (char "z") 77 jle 40 # Yes 78 end 79 cmp A 128 80 jeq 40 # Yes 81 cmp A 224 82 if ge 83 cmp A 255 84 if le # Yes 85 40 off B 32 # Convert to lower case 86 end 87 end 88 push A # <S> Last character 89 xchg C (S II) # Swap status 90 xchg X (S I) 91 call charSymACX_CX # Pack first char 92 xchg X (S I) # Swap status 93 xchg C (S II) 94 do 95 call symCharCX_FACX # Next char? 96 while nz # Yes 97 cmp A 32 # Non-white? 98 if gt # Yes 99 sub A SNXBASE # Too small? 100 jlt 60 # Yes 101 cmp A SNXSIZE # Too big? 102 jge 60 # Yes 103 ld B (A SnxTab) # Character entry? 104 zxt 105 or A A 106 if z # No 107 60 ld (S) 0 # Clear last character 108 else 109 cmp A (S) # Same as last? 110 if ne # No 111 dec E # Decrement count 112 break z 113 ld (S) A # Save last character 114 xchg C (S II) # Swap status 115 xchg X (S I) 116 call charSymACX_CX # Pack char 117 xchg X (S I) # Swap status 118 xchg C (S II) 119 end 120 end 121 end 122 loop 123 90 ld X (L I) # Get result 124 call consSymX_E # Make transient symbol 125 drop 126 end 127 pop Y 128 pop X 129 ret 130 131 132 ### File Descriptor ### 133 # (ext:FD 'cnt) -> fd 134 (code 'FD 2) 135 push X 136 ld X E 137 ld E ((E CDR)) # Eval 'cnt' 138 eval 139 push E # Save result 140 call xCntEX_FE 141 if ns 142 ld X E # Keep file descriptor 143 ld A E 144 call initInFileA_A # Init input file 145 ld A X 146 call initOutFileA_A # and output file 147 end 148 pop E # Get result 149 pop X 150 ret 151 152 153 ### Audio Data ### 154 (equ BIAS 132) 155 (equ CLIP (- 32767 BIAS)) 156 157 # (ext:Ulaw 'cnt) -> cnt # SEEEMMMM 158 (code 'Ulaw 2) 159 push X 160 ld X E 161 ld E ((E CDR)) # Get arg 162 eval # Eval 'cnt' 163 cnt E # # Short number? 164 jz cntErrEX # No 165 ld X 0 # No sign 166 shr E 4 # Normalize 167 if c # Negative? 168 ld X (hex "80") # Set sign 169 end 170 cmp E (+ CLIP 1) # Clip the value 171 ldnc E CLIP 172 add E BIAS # Increment by BIAS 173 ld A E # Double value 174 add A A # in 'tmp' 175 ld C 7 # Exponent 176 do 177 test A (hex "8000") 178 while z 179 add A A # Double 'tmp' 180 dec C # Decrement exponent 181 until z 182 ld A C # Get exponent 183 add A 3 # plus 3 184 shr E A # Shift value right 185 and E 15 # Lowest 4 bits 186 shl C 4 # Shift exponent left 187 or E C # Combine with value 188 or E X # and sign 189 not E # Negate 190 and E (hex "FF") # Get byte value 191 shl E 4 # Make short number 192 or E CNT 193 pop X 194 ret 195 196 197 ### Base64 Encoding ### 198 (data 'Chr64) 199 ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 200 201 # (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg 202 (code 'Base64 2) 203 push X 204 push Y 205 push Z 206 ld X E 207 ld Y (E CDR) # Y on args 208 ld E (Y) # Eval first 'num|NIL' 209 eval 210 cmp E Nil # NIL? 211 if ne # No 212 shr E 4 # Normalize first arg 213 ld Z E # Keep in Z 214 shr E 2 # Upper 6 bits 215 call chr64E # Output encoded 216 ld Y (Y CDR) # Next arg 217 ld E (Y) 218 eval # Eval second arg 219 cmp E Nil # NIL? 220 if eq # Yes 221 ld E Z # Get first arg 222 and E 3 # Mask 223 shl E 4 # Shift to upper position 224 call chr64E # Output encoded 225 ld B (char "=") # and two equal signs 226 call (PutB) 227 ld B (char "=") 228 call (PutB) 229 ld E Nil # Return NIL 230 else 231 shr E 4 # Normalize second arg 232 and Z 3 # Mask first arg 233 shl Z 4 # Shift to upper position 234 ld A E # Get second arg 235 shr A 4 # Normalize 236 or A Z # Combine 237 ld Z E # Keep second arg in Z 238 call chr64A # Output encoded 239 ld Y (Y CDR) # Next arg 240 ld E (Y) 241 eval # Eval third arg 242 cmp E Nil # NIL? 243 if eq # Yes 244 ld A Z # Get second 245 and A 15 # Lowest four bits 246 shl A 2 # Shift 247 call chr64A # Output encoded 248 ld B (char "=") # and an equal sign 249 call (PutB) 250 ld E Nil # Return NIL 251 else 252 shr E 4 # Normalize third arg 253 ld A E 254 shr A 6 # Upper bits 255 and Z 15 # Lowest four bits of second arg 256 shl Z 2 # Shift 257 or A Z # Combine 258 call chr64A # Output encoded 259 and E 63 # Last arg 260 call chr64E # Output encoded 261 ld E TSym # Return T 262 end 263 end 264 end 265 pop Z 266 pop Y 267 pop X 268 ret 269 270 (code 'chr64E) 271 ld A E 272 (code 'chr64A) 273 ld B (A Chr64) # Fetch from table 274 jmp (PutB) # Output byte 275 276 # vi:et:ts=3:sw=3