Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-coding.el @ 4295:eded49463f9a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2007-11-29 13:37:51 by aidan] Add round-trip tests for my fixed-width-8-bit CCL coding systems, fix a bug with them, take out some inadvertant debugging code of mine from mule-ccl.c.
author aidan
date Thu, 29 Nov 2007 13:38:21 +0000
parents edb00a8b4eff
children f4c3ffe60a4f
comparison
equal deleted inserted replaced
4294:01a2c678e91f 4295:eded49463f9a
231 Deals with the case where ASCII and another character set can both be 231 Deals with the case where ASCII and another character set can both be
232 encoded unambiguously and completely into the coding-system; if this is so, 232 encoded unambiguously and completely into the coding-system; if this is so,
233 returns a list corresponding to such a ccl-program. If not, it returns nil. " 233 returns a list corresponding to such a ccl-program. If not, it returns nil. "
234 (let ((tentative-encode-program-parts 234 (let ((tentative-encode-program-parts
235 (eval-when-compile 235 (eval-when-compile
236 (let* ((compiled 236 (let* ((vec-len 128)
237 (compiled
237 (append 238 (append
238 (ccl-compile 239 (ccl-compile
239 `(1 240 `(1
240 (loop 241 (loop
241 (read-multibyte-character r0 r1) 242 (read-multibyte-character r0 r1)
242 (if (r0 == ,(charset-id 'ascii)) 243 (if (r0 == ,(charset-id 'ascii))
243 (write r1) 244 (write r1)
244 ((if (r0 == #xABAB) 245 ((if (r0 == #xABAB)
245 ;; #xBFFE is a sentinel in the compiled 246 ;; #xBFFE is a sentinel in the compiled
246 ;; program. 247 ;; program.
247 (write r1 ,(make-vector 256 #xBFFE)) 248 ;; #xBFFE is a sentinel in the compiled
249 ;; program.
250 ((r0 = r1 & #x7F)
251 (write r0 ,(make-vector vec-len #xBFFE)))
248 ((mule-to-unicode r0 r1) 252 ((mule-to-unicode r0 r1)
249 (if (r0 == #xFFFD) 253 (if (r0 == #xFFFD)
250 (write #xBEEF) 254 (write #xBEEF)
251 ((lookup-integer encode-table-sym r0 r3) 255 ((lookup-integer encode-table-sym r0 r3)
252 (if r7 256 (if r7
258 (member-if-not (lambda (entr) (eq #xBFFE entr)) 262 (member-if-not (lambda (entr) (eq #xBFFE entr))
259 (member-if 263 (member-if
260 (lambda (entr) (eq #xBFFE entr)) 264 (lambda (entr) (eq #xBFFE entr))
261 first-part)))) 265 first-part))))
262 (while compiled 266 (while compiled
263 (if (eq #xBFFE (cadr compiled)) 267 (when (eq #xBFFE (cadr compiled))
264 (setcdr compiled nil)) 268 (assert (= vec-len (search '(#xBFFE) (cdr compiled)
269 :test #'/=)) nil
270 "Strange ccl vector length")
271 (setcdr compiled nil))
265 (setq compiled (cdr compiled))) 272 (setq compiled (cdr compiled)))
266 ;; Is the generated code as we expect it to be? 273 ;; Is the generated code as we expect it to be?
267 (assert (and (memq #xABAB first-part) 274 (assert (and (memq #xABAB first-part)
268 (memq #xBEEF14 last-part)) 275 (memq #xBEEF14 last-part))
269 nil 276 nil
270 "This code assumes that the constant #xBEEF is #xBEEF14 in \ 277 "This code assumes that the constant #xBEEF is #xBEEF14 in \
271 compiled CCL code,\nand that the constant #xABAB is #xABAB. If that is 278 compiled CCL code,\nand that the constant #xABAB is #xABAB. If that is
272 not the case, and it appears not to be--that's why you're getting this 279 not the case, and it appears not to be--that's why you're getting this
273 message--it will not work. ") 280 message--it will not work. ")
274 (list first-part last-part)))) 281 (list first-part last-part vec-len))))
275 (charset-lower -1) 282 (charset-lower -1)
276 (charset-upper -1) 283 (charset-upper -1)
277 worth-trying known-charsets encode-program 284 worth-trying known-charsets encode-program
278 other-charset-vector ucs) 285 other-charset-vector ucs args-out-of-range)
279 286
280 (loop for char across decode-table 287 (loop for char across decode-table
281 do (pushnew (char-charset char) known-charsets)) 288 do (pushnew (char-charset char) known-charsets))
282 (setq known-charsets (delq 'ascii known-charsets)) 289 (setq known-charsets (delq 'ascii known-charsets))
283 290
309 (setq charset-lower -1 316 (setq charset-lower -1
310 charset-upper -1 317 charset-upper -1
311 worth-trying nil))) 318 worth-trying nil)))
312 319
313 (when worth-trying 320 (when worth-trying
314 (setq other-charset-vector (make-vector 128 encode-failure-octet)) 321 (setq other-charset-vector
322 (make-vector (third tentative-encode-program-parts)
323 encode-failure-octet))
315 (loop for i from charset-lower to charset-upper 324 (loop for i from charset-lower to charset-upper
316 do (aset other-charset-vector i 325 do (aset other-charset-vector i
317 (gethash (encode-char (make-char worth-trying i) 326 (gethash (encode-char (make-char worth-trying i)
318 'ucs) encode-table))) 327 'ucs) encode-table)))
319 (setq encode-program 328 (setq encode-program
609 (make-coding-system 618 (make-coding-system
610 name 'ccl 619 name 'ccl
611 description 620 description
612 (plist-put (plist-put props 'decode decode-program) 621 (plist-put (plist-put props 'decode decode-program)
613 'encode encode-program))) 622 'encode encode-program)))
623 (coding-system-put name '8-bit-fixed t)
614 (coding-system-put name 'category 624 (coding-system-put name 'category
615 (make-8-bit-choose-category decode-table)) 625 (make-8-bit-choose-category decode-table))
616 (loop for alias in aliases 626 (loop for alias in aliases
617 do (define-coding-system-alias alias name)) 627 do (define-coding-system-alias alias name))
618 result)) 628 result))
680 (nsublis 690 (nsublis
681 (list (cons 691 (list (cons
682 'encode-table-sym 692 'encode-table-sym
683 (symbol-value 'encode-table-sym))) 693 (symbol-value 'encode-table-sym)))
684 ',encode-program)))) 694 ',encode-program))))
695 (coding-system-put ',name '8-bit-fixed t)
685 (coding-system-put ',name 'category ', 696 (coding-system-put ',name 'category ',
686 (make-8-bit-choose-category decode-table)) 697 (make-8-bit-choose-category decode-table))
687 ,(macroexpand `(loop for alias in ',aliases 698 ,(macroexpand `(loop for alias in ',aliases
688 do (define-coding-system-alias alias 699 do (define-coding-system-alias alias
689 ',name))) 700 ',name)))