From d9e3229d1e8b7797d452d261a37da0d0394546d0 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Thu, 22 Jan 1998 01:42:20 +0000 Subject: [PATCH] (define-character-unification-table): New function. (coding-system-base): Doc-string modified. (make-coding-system): The 6th optional arg is changed to PROPERTIES. (set-buffer-file-coding-system): Show "(default, nil)" in prompt. (set-coding-priority): Code tuned. --- lisp/international/mule.el | 124 ++++++++++++++++++++++++------------- 1 file changed, 82 insertions(+), 42 deletions(-) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index f26d0105788..c13b6817e57 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -389,8 +389,8 @@ for more detail." (defun coding-system-base (coding-system) "Return the base coding system of CODING-SYSTEM. -A base coding system is what made by `make-coding-system', -not what made by `define-coding-system-alias'." +A base coding system is what made by `make-coding-system'. +Any alias nor subsidiary coding systems are not base coding system." (car (coding-system-get coding-system 'alias-coding-systems))) (defalias 'coding-system-parent 'coding-system-base) @@ -438,10 +438,10 @@ coding system whose eol-type is N." subsidiaries)) (defun make-coding-system (coding-system type mnemonic doc-string - &optional flags safe-charsets) + &optional flags properties) "Define a new CODING-SYSTEM (symbol). Remaining arguments are TYPE, MNEMONIC, DOC-STRING, FLAGS (optional), -and CHARSETS (optional) which construct a coding-spec of CODING-SYSTEM +and PROPERTIES (optional) which construct a coding-spec of CODING-SYSTEM in the following format: [TYPE MNEMONIC DOC-STRING PLIST FLAGS] TYPE is an integer value indicating the type of coding-system as follows: @@ -456,12 +456,6 @@ MNEMONIC is a character to be displayed on mode line for the coding-system. DOC-STRING is a documentation string for the coding-system. -PLIST is the propert list for CODING-SYSTEM. This function sets -properties coding-category, alias-coding-systems, safe-charsets. The -first two are set automatically. The last one is set to the argument -SAFE-CHARSETS. SAFE-CHARSETS is a list of character sets encoded -safely in CODING-SYSTEM, or t which means all character sets are safe. - FLAGS specifies more precise information of each TYPE. If TYPE is 2 (ISO-2022), FLAGS should be a list of: @@ -495,14 +489,23 @@ FLAGS specifies more precise information of each TYPE. code of the coding system. If TYPE is 4 (private), FLAGS should be a cons of CCL programs, - for decoding and encoding. See the documentation of CCL for more detail." + for decoding and encoding. See the documentation of CCL for more detail. + +PROPERTIES is an alist of properties vs the corresponding values. +These properties are set in PLIST, a property list. This function +also sets properties `coding-category' and `alias-coding-systems' +automatically. +Kludgy feature: For backward compatibility, if PROPERTIES is a list of +character sets, the list is set as a value of `safe-charsets' in +PLIST." (if (memq coding-system coding-system-list) - (error "Coding system %s already exists")) + (error "Coding system %s already exists" coding-system)) ;; Set a value of `coding-system' property. (let ((coding-spec (make-vector 5 nil)) - (no-initial-designation nil) + (no-initial-designation t) + (no-alternative-designation t) coding-category) (if (or (not (integerp type)) (< type 0) (> type 5)) (error "TYPE argument must be 0..5")) @@ -520,7 +523,6 @@ FLAGS specifies more precise information of each TYPE. (let ((i 0) (vec (make-vector 32 nil)) (g1-designation nil)) - (setq no-initial-designation t) (while (< i 4) (let ((charset (car flags))) (if (and no-initial-designation @@ -536,12 +538,16 @@ FLAGS specifies more precise information of each TYPE. elt) (while tail (setq elt (car tail)) - (or (not elt) (eq elt t) (charsetp elt) - (error "Invalid charset: %s" elt)) + (if (eq elt t) + (setq no-alternative-designation nil) + (if (and elt (not (charsetp elt))) + (error "Invalid charset: %s" elt))) (setq tail (cdr tail))) (setq g1-designation (car charset))) - (if (and charset (not (eq charset t))) - (error "Invalid charset: %s" charset)))) + (if charset + (if (eq charset t) + (setq no-alternative-designation nil) + (error "Invalid charset: %s" charset))))) (aset vec i charset)) (setq flags (cdr flags) i (1+ i))) (while (and (< i 32) flags) @@ -555,7 +561,9 @@ FLAGS specifies more precise information of each TYPE. (if (aref vec 7) ; 7-bit only. (if (aref vec 9) ; Use single-shift. 'coding-category-iso-7-else - 'coding-category-iso-7) + (if no-alternative-designation + 'coding-category-iso-7-tight + 'coding-category-iso-7)) (if no-initial-designation 'coding-category-iso-8-else (if (and (charsetp g1-designation) @@ -575,11 +583,18 @@ FLAGS specifies more precise information of each TYPE. (setq coding-category 'coding-category-raw-text))) (let ((plist (list 'coding-category coding-category - 'alias-coding-systems (list coding-system) - 'safe-charsets safe-charsets))) + 'alias-coding-systems (list coding-system)))) (if no-initial-designation - (setq plist (cons 'no-initial-designation - (cons no-initial-designation plist)))) + (plist-put plist 'no-initial-designation t)) + (if (and properties + (or (eq properties t) + (not (consp (car properties))))) + ;; In the old version, the arg PROPERTIES is a list to be + ;; set in PLIST as a value of property `safe-charsets'. + (plist-put plist 'safe-charsets properties) + (while properties + (plist-put plist (car (car properties)) (cdr (car properties))) + (setq properties (cdr properties)))) (aset coding-spec coding-spec-plist-idx plist)) (put coding-system 'coding-system coding-spec) (put coding-category 'coding-systems @@ -597,7 +612,8 @@ FLAGS specifies more precise information of each TYPE. ;; `coding-system-alist'. (setq coding-system-list (cons coding-system coding-system-list)) (setq coding-system-alist (cons (list (symbol-name coding-system)) - coding-system-alist))) + coding-system-alist)) + coding-system) (defun define-coding-system-alias (alias coding-system) "Define ALIAS as an alias for coding system CODING-SYSTEM." @@ -622,7 +638,7 @@ conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is merged with the already-specified end-of-line conversion. However, if the optional prefix argument FORCE is non-nil, then CODING-SYSTEM is used exactly as specified." - (interactive "zCoding system for visited file: \nP") + (interactive "zCoding system for visited file (default, nil): \nP") (check-coding-system coding-system) (if (null force) (let ((x (coding-system-eol-type buffer-file-coding-system)) @@ -706,24 +722,21 @@ For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]." (force-mode-line-update)) (defun set-coding-priority (arg) - "Set priority of coding-category according to LIST. -LIST is a list of coding-categories ordered by priority." - (let (l) - ;; Put coding-categories listed in ARG to L while checking the - ;; validity. We assume that `coding-category-list' contains whole - ;; coding-categories. - (while arg - (if (null (memq (car arg) coding-category-list)) - (error "Invalid element in argument: %s" (car arg))) - (setq l (cons (car arg) l)) - (setq arg (cdr arg))) - ;; Put coding-category not listed in ARG to L. - (while coding-category-list - (if (null (memq (car coding-category-list) l)) - (setq l (cons (car coding-category-list) l))) - (setq coding-category-list (cdr coding-category-list))) + "Set priority of coding categories according to LIST. +LIST is a list of coding categories ordered by priority." + (let ((l arg) + (current-list (copy-sequence coding-category-list))) + ;; Check the varidity of ARG while deleting coding categories in + ;; ARG from CURRENT-LIST. We assume that CODING-CATEGORY-LIST + ;; contains all coding categories. + (while l + (if (or (null (get (car l) 'coding-category-index)) + (null (memq (car l) current-list))) + (error "Invalid or duplicated element in argument: %s" arg)) + (setq current-list (delq (car l) current-list)) + (setq l (cdr l))) ;; Update `coding-category-list' and return it. - (setq coding-category-list (nreverse l)))) + (setq coding-category-list (append arg current-list)))) ;;; FILE I/O @@ -998,6 +1011,33 @@ without changing their position code(s)." ;; Return TABLE just created. table)) +(defun define-character-unification-table (symbol &rest args) + "define character unification table. This function call make-unification-table, +store a returned table to character-unification-table-vector. +And then set the table as SYMBOL's unification-table property, +the index of the vector as SYMBOL's unification-table-id." + (let ((table (apply 'make-unification-table args)) + (len (length character-unification-table-vector)) + (id 0) + slot) + (or (symbolp symbol) + (signal 'wrong-type-argument symbol)) + (put symbol 'unification-table table) + (while (and (< id len) + (if (consp (setq slot (aref character-unification-table-vector id))) + (if (eq (car slot) symbol) nil t) + (aset character-unification-table-vector id (cons symbol table)) + nil)) + (setq id (1+ id))) + (if (= id len) + (progn + (setq character-unification-table-vector + (vconcat character-unification-table-vector (make-vector len nil))) + (aset character-unification-table-vector id (cons symbol table)))) + (put symbol 'unification-table-id id) + id)) + + ;;; Initialize some variables. (put 'use-default-ascent 'char-table-extra-slots 0) -- 2.39.2