Mercurial > emacs

comparison lisp/international/mule.el @ 18298:3d036a21fc93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(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