Mercurial > emacs
comparison lisp/international/mule.el @ 18298:3d036a21fc93
(coding-system-type): Doc-string modified.
(coding-system-category): New function.
(make-subsidiary-coding-system): Argument BASE deleted.
(make-coding-system): Put properties no-initial-designation and
coding-category to a newly created coding system.
(define-coding-system-alias): Put property parent-coding-system
to a new alias, property alias-coding-systems to a parent.
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Wed, 18 Jun 1997 12:55:09 +0000 |
parents | 9650375d0a68 |
children | 705da3ce58c0 |
comparison
equal
deleted
inserted
replaced
18297:5c8e37591da5 | 18298:3d036a21fc93 |
---|---|
259 (check-coding-system coding-system) | 259 (check-coding-system coding-system) |
260 (let ((vec (coding-system-spec coding-system))) | 260 (let ((vec (coding-system-spec coding-system))) |
261 (and vec (aref vec n)))) | 261 (and vec (aref vec n)))) |
262 | 262 |
263 (defun coding-system-type (coding-system) | 263 (defun coding-system-type (coding-system) |
264 "Return TYPE element in coding-spec of CODING-SYSTEM." | 264 "Return TYPE element in coding-spec of CODING-SYSTEM." |
265 (coding-system-spec-ref coding-system coding-spec-type-idx)) | 265 (coding-system-spec-ref coding-system coding-spec-type-idx)) |
266 | 266 |
267 (defun coding-system-mnemonic (coding-system) | 267 (defun coding-system-mnemonic (coding-system) |
268 "Return MNEMONIC element in coding-spec of CODING-SYSTEM." | 268 "Return MNEMONIC element in coding-spec of CODING-SYSTEM." |
269 (or (coding-system-spec-ref coding-system coding-spec-mnemonic-idx) | 269 (or (coding-system-spec-ref coding-system coding-spec-mnemonic-idx) |
282 (check-coding-system coding-system) | 282 (check-coding-system coding-system) |
283 (and coding-system | 283 (and coding-system |
284 (or (get coding-system 'eol-type) | 284 (or (get coding-system 'eol-type) |
285 (coding-system-eol-type (get coding-system 'coding-system))))) | 285 (coding-system-eol-type (get coding-system 'coding-system))))) |
286 | 286 |
287 ;; Make subsidiear coding systems of CODING-SYSTEM whose base is BASE. | 287 (defun coding-system-category (coding-system) |
288 (defun make-subsidiary-coding-system (coding-system base) | 288 "Return coding category of CODING-SYSTEM." |
289 (and coding-system | |
290 (symbolp coding-system) | |
291 (or (get coding-system 'coding-category) | |
292 (coding-system-category (get coding-system 'coding-system))))) | |
293 | |
294 ;; Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM. | |
295 (defun make-subsidiary-coding-system (coding-system) | |
289 (let ((subsidiaries (vector (intern (format "%s-unix" coding-system)) | 296 (let ((subsidiaries (vector (intern (format "%s-unix" coding-system)) |
290 (intern (format "%s-dos" coding-system)) | 297 (intern (format "%s-dos" coding-system)) |
291 (intern (format "%s-mac" coding-system)))) | 298 (intern (format "%s-mac" coding-system)))) |
292 (i 0)) | 299 (i 0)) |
293 (while (< i 3) | 300 (while (< i 3) |
294 (put (aref subsidiaries i) 'coding-system base) | 301 (put (aref subsidiaries i) 'coding-system coding-system) |
295 (put (aref subsidiaries i) 'eol-type i) | 302 (put (aref subsidiaries i) 'eol-type i) |
296 (put (aref subsidiaries i) 'eol-variant t) | 303 (put (aref subsidiaries i) 'eol-variant t) |
297 (setq i (1+ i))) | 304 (setq i (1+ i))) |
298 subsidiaries)) | 305 subsidiaries)) |
299 | 306 |
337 at beginning of line on output. | 344 at beginning of line on output. |
338 If TYPE is 4 (private), FLAGS should be a cons of CCL programs, | 345 If TYPE is 4 (private), FLAGS should be a cons of CCL programs, |
339 for encoding and decoding. See the documentation of CCL for more detail." | 346 for encoding and decoding. See the documentation of CCL for more detail." |
340 | 347 |
341 ;; At first, set a value of `coding-system' property. | 348 ;; At first, set a value of `coding-system' property. |
342 (let ((coding-spec (make-vector 5 nil))) | 349 (let ((coding-spec (make-vector 5 nil)) |
350 coding-category) | |
343 (if (or (not (integerp type)) (< type 0) (> type 4)) | 351 (if (or (not (integerp type)) (< type 0) (> type 4)) |
344 (error "TYPE argument must be 0..4")) | 352 (error "TYPE argument must be 0..4")) |
345 (if (or (not (integerp mnemonic)) (<= mnemonic ? ) (> mnemonic 127)) | 353 (if (or (not (integerp mnemonic)) (<= mnemonic ? ) (> mnemonic 127)) |
346 (error "MNEMONIC arguemnt must be a printable character.")) | 354 (error "MNEMONIC arguemnt must be a printable character.")) |
347 (aset coding-spec 0 type) | 355 (aset coding-spec 0 type) |
348 (aset coding-spec 1 mnemonic) | 356 (aset coding-spec 1 mnemonic) |
349 (aset coding-spec 2 (if (stringp doc-string) doc-string "")) | 357 (aset coding-spec 2 (if (stringp doc-string) doc-string "")) |
350 (aset coding-spec 3 nil) ; obsolete element | 358 (aset coding-spec 3 nil) ; obsolete element |
351 (cond ((eq type 2) ; ISO2022 | 359 (cond ((= type 0) |
360 (setq coding-category 'coding-category-emacs-mule)) | |
361 ((= type 1) | |
362 (setq coding-category 'coding-category-sjis)) | |
363 ((= type 2) ; ISO2022 | |
352 (let ((i 0) | 364 (let ((i 0) |
353 (vec (make-vector 32 nil))) | 365 (vec (make-vector 32 nil)) |
366 (no-initial-designation t) | |
367 (g1-designation nil)) | |
354 (while (< i 4) | 368 (while (< i 4) |
355 (let ((charset (car flags))) | 369 (let ((charset (car flags))) |
356 (or (not charset) (eq charset t) (charsetp charset) | 370 (if (and no-initial-designation |
357 (if (not (listp charset)) | 371 (> i 0) |
358 (error "Invalid charset: %s" charset) | 372 (or (charsetp charset) |
359 (let (elt l) | 373 (and (consp charset) |
360 (while charset | 374 (charsetp (car charset))))) |
361 (setq elt (car charset)) | 375 (setq no-initial-designation nil)) |
376 (if (charsetp charset) | |
377 (if (= i 1) (setq g1-designation charset)) | |
378 (if (consp charset) | |
379 (let ((tail charset) | |
380 elt) | |
381 (while tail | |
382 (setq elt (car tail)) | |
362 (or (not elt) (eq elt t) (charsetp elt) | 383 (or (not elt) (eq elt t) (charsetp elt) |
363 (error "Invalid charset: %s" elt)) | 384 (error "Invalid charset: %s" elt)) |
364 (setq l (cons elt l)) | 385 (setq tail (cdr tail))) |
365 (setq charset (cdr charset))) | 386 (setq g1-designation (car charset))) |
366 (setq charset (nreverse l))))) | 387 (if (and charset (not (eq charset t))) |
388 (error "Invalid charset: %s" charset)))) | |
367 (aset vec i charset)) | 389 (aset vec i charset)) |
368 (setq flags (cdr flags) i (1+ i))) | 390 (setq flags (cdr flags) i (1+ i))) |
369 (while (and (< i 32) flags) | 391 (while (and (< i 32) flags) |
370 (aset vec i (car flags)) | 392 (aset vec i (car flags)) |
371 (setq flags (cdr flags) i (1+ i))) | 393 (setq flags (cdr flags) i (1+ i))) |
372 (aset coding-spec 4 vec))) | 394 (aset coding-spec 4 vec) |
373 ((eq type 4) ; private | 395 (if no-initial-designation |
396 (put coding-system 'no-initial-designation t)) | |
397 (setq coding-category | |
398 (if (aref vec 8) ; Use locking-shift. | |
399 'coding-category-iso-else | |
400 (if (aref vec 7) ; 7-bit only. | |
401 (if (aref vec 9) ; Use single-shift. | |
402 'coding-category-iso-else | |
403 'coding-category-iso-7) | |
404 (if no-initial-designation | |
405 'coding-category-iso-else | |
406 (if (and (charsetp g1-designation) | |
407 (= (charset-dimension g1-designation) 2)) | |
408 'coding-category-iso-8-2 | |
409 'coding-category-iso-8-1))))))) | |
410 ((= type 3) | |
411 (setq coding-category 'coding-category-big5)) | |
412 ((= type 4) ; private | |
413 (setq coding-category 'coding-category-binary) | |
374 (if (and (consp flags) | 414 (if (and (consp flags) |
375 (vectorp (car flags)) | 415 (vectorp (car flags)) |
376 (vectorp (cdr flags))) | 416 (vectorp (cdr flags))) |
377 (aset coding-spec 4 flags) | 417 (aset coding-spec 4 flags) |
378 (error "Invalid FLAGS argument for TYPE 4 (CCL)"))) | 418 (error "Invalid FLAGS argument for TYPE 4 (CCL)")))) |
379 (t (aset coding-spec 4 flags))) | 419 (put coding-system 'coding-system coding-spec) |
380 (put coding-system 'coding-system coding-spec)) | 420 (put coding-system 'coding-category coding-category) |
421 (put coding-category 'coding-systems | |
422 (cons coding-system (get coding-category 'coding-systems)))) | |
381 | 423 |
382 ;; Next, set a value of `eol-type' property. The value is a vector | 424 ;; Next, set a value of `eol-type' property. The value is a vector |
383 ;; of subsidiary coding systems, each corresponds to a coding-system | 425 ;; of subsidiary coding systems, each corresponds to a coding system |
384 ;; for the detected end-of-line format. | 426 ;; for the detected end-of-line format. |
385 (put coding-system 'eol-type | 427 (put coding-system 'eol-type |
386 (if (<= type 3) | 428 (if (<= type 3) |
387 (make-subsidiary-coding-system coding-system coding-system) | 429 (make-subsidiary-coding-system coding-system) |
388 0))) | 430 0))) |
389 | 431 |
390 (defun define-coding-system-alias (coding-system alias) | 432 (defun define-coding-system-alias (coding-system alias) |
391 "Define ALIAS as an alias coding system of CODING-SYSTEM." | 433 "Define ALIAS as an alias coding system of CODING-SYSTEM." |
392 (check-coding-system coding-system) | 434 (check-coding-system coding-system) |
435 (let ((parent (coding-system-parent coding-system))) | |
436 (if parent | |
437 (setq coding-system parent))) | |
393 (put alias 'coding-system coding-system) | 438 (put alias 'coding-system coding-system) |
394 (if (vectorp (coding-system-eol-type coding-system)) | 439 (put alias 'parent-coding-system coding-system) |
395 (make-subsidiary-coding-system alias coding-system))) | 440 (put coding-system 'alias-coding-systems |
441 (cons alias (get coding-system 'alias-coding-systems))) | |
442 (let ((eol-variants (coding-system-eol-type coding-system)) | |
443 subsidiaries) | |
444 (if (vectorp eol-variants) | |
445 (let ((i 0)) | |
446 (setq subsidiaries (make-subsidiary-coding-system alias)) | |
447 (while (< i 3) | |
448 (put (aref subsidiaries i) 'parent-coding-system | |
449 (aref eol-variants i)) | |
450 (put (aref eol-variants i) 'alias-coding-systems | |
451 (cons (aref subsidiaries i) (get (aref eol-variants i) | |
452 'alias-coding-systems))) | |
453 (setq i (1+ i))))))) | |
396 | 454 |
397 (defun set-buffer-file-coding-system (coding-system &optional force) | 455 (defun set-buffer-file-coding-system (coding-system &optional force) |
398 "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM. | 456 "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM. |
399 If eol-type of the current buffer-file-coding-system is an integer value N, and | 457 If eol-type of the current buffer-file-coding-system is an integer value N, and |
400 eol-type of CODING-SYSTEM is a vector, the Nth element of the vector is used | 458 eol-type of CODING-SYSTEM is a vector, the Nth element of the vector is used |