X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b71f2b97d343dd5ec39b64b66de86051ee47eb3e..40fb2103c2986cbb91add4afed635886c4f87ae5:/lisp/international/mule-cmds.el?ds=sidebyside diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 4c93ee6255..9d3cd06851 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1,7 +1,8 @@ ;;; mule-cmds.el --- commands for mulitilingual environment -*-coding: iso-2022-7bit -*- + +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Copyright (C) 1995, 2003 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. -;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +;; Licensed to the Free Software Foundation. ;; Copyright (C) 2003 ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H13PRO009 @@ -331,7 +332,8 @@ This also sets the following values: (or (local-variable-p 'buffer-file-coding-system buffer) (ucs-set-table-for-input buffer)))) - (if default-enable-multibyte-characters + (if (and default-enable-multibyte-characters (not (eq system-type 'darwin))) + ;; The file-name coding system on Darwin systems is always utf-8. (setq default-file-name-coding-system coding-system)) ;; If coding-system is nil, honor that on MS-DOS as well, so ;; that they could reset the terminal coding system. @@ -611,6 +613,176 @@ The meaning is the same as the argument ACCEPT-DEFAULT-P of the function `select-safe-coding-system' (which see). This variable overrides that argument.") +(defun select-safe-coding-system-interactively (from to codings unsafe + &optional rejected default) + "Select interactively a coding system for the region FROM ... TO. +FROM can be a string, as in `write-region'. +CODINGS is the list of base coding systems known to be safe for this region, + typically obtained with `find-coding-systems-region'. +UNSAFE is a list of coding systems known to be unsafe for this region. +REJECTED is a list of coding systems which were safe but for some reason + were not recommended in the particular context. +DEFAULT is the coding system to use by default in the query." + ;; At first, if some defaults are unsafe, record at most 11 + ;; problematic characters and their positions for them by turning + ;; (CODING ...) + ;; into + ;; ((CODING (POS . CHAR) (POS . CHAR) ...) ...) + (if unsafe + (setq unsafe + (mapcar #'(lambda (coding) + (cons coding + (if (stringp from) + (mapcar #'(lambda (pos) + (cons pos (aref from pos))) + (unencodable-char-position + 0 (length from) coding + 11 from)) + (mapcar #'(lambda (pos) + (cons pos (char-after pos))) + (unencodable-char-position + from to coding 11))))) + unsafe))) + + ;; Change each safe coding system to the corresponding + ;; mime-charset name if it is also a coding system. Such a name + ;; is more friendly to users. + (let ((l codings) + mime-charset) + (while l + (setq mime-charset (coding-system-get (car l) :mime-charset)) + (if (and mime-charset (coding-system-p mime-charset) + (coding-system-equal (car l) mime-charset)) + (setcar l mime-charset)) + (setq l (cdr l)))) + + ;; Don't offer variations with locking shift, which you + ;; basically never want. + (let (l) + (dolist (elt codings (setq codings (nreverse l))) + (unless (or (eq 'coding-category-iso-7-else + (coding-system-category elt)) + (eq 'coding-category-iso-8-else + (coding-system-category elt))) + (push elt l)))) + + ;; Remove raw-text, emacs-mule and no-conversion unless nothing + ;; else is available. + (setq codings + (or (delq 'raw-text + (delq 'emacs-mule + (delq 'no-conversion codings))) + '(raw-text emacs-mule no-conversion))) + + (let ((window-configuration (current-window-configuration)) + (bufname (buffer-name)) + coding-system) + (save-excursion + ;; If some defaults are unsafe, make sure the offending + ;; buffer is displayed. + (when (and unsafe (not (stringp from))) + (pop-to-buffer bufname) + (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x))) + unsafe)))) + ;; Then ask users to select one from CODINGS while showing + ;; the reason why none of the defaults are not used. + (with-output-to-temp-buffer "*Warning*" + (with-current-buffer standard-output + (if (and (null rejected) (null unsafe)) + (insert "No default coding systems to try for " + (if (stringp from) + (format "string \"%s\"." from) + (format "buffer `%s'." bufname))) + (insert + "These default coding systems were tried to encode" + (if (stringp from) + (concat " \"" (if (> (length from) 10) + (concat (substring from 0 10) "...\"") + (concat from "\""))) + (format " text\nin the buffer `%s'" bufname)) + ":\n") + (let ((pos (point)) + (fill-prefix " ")) + (dolist (x (append rejected unsafe)) + (princ " ") (princ (car x))) + (insert "\n") + (fill-region-as-paragraph pos (point))) + (when rejected + (insert "These safely encodes the target text, +but it is not recommended for encoding text in this context, +e.g., for sending an email message.\n ") + (dolist (x rejected) + (princ " ") (princ x)) + (insert "\n")) + (when unsafe + (insert (if rejected "And the others" + "However, each of them") + " encountered these problematic characters:\n") + (dolist (coding unsafe) + (insert (format " %s:" (car coding))) + (let ((i 0) + (func1 + #'(lambda (bufname pos) + (when (buffer-live-p (get-buffer bufname)) + (pop-to-buffer bufname) + (goto-char pos)))) + (func2 + #'(lambda (bufname pos coding) + (when (buffer-live-p (get-buffer bufname)) + (pop-to-buffer bufname) + (if (< (point) pos) + (goto-char pos) + (forward-char 1) + (search-unencodable-char coding) + (forward-char -1)))))) + (dolist (elt (cdr coding)) + (insert " ") + (if (stringp from) + (insert (if (< i 10) (cdr elt) "...")) + (if (< i 10) + (insert-text-button + (cdr elt) + :type 'help-xref + 'help-echo + "mouse-2, RET: jump to this character" + 'help-function func1 + 'help-args (list bufname (car elt))) + (insert-text-button + "..." + :type 'help-xref + 'help-echo + "mouse-2, RET: next unencodable character" + 'help-function func2 + 'help-args (list bufname (car elt) + (car coding))))) + (setq i (1+ i)))) + (insert "\n")) + (insert "\ +The first problematic character is at point in the displayed buffer,\n" + (substitute-command-keys "\ +and \\[universal-argument] \\[what-cursor-position] will give information about it.\n")))) + (insert "\nSelect \ +one of the following safe coding systems, or edit the buffer:\n") + (let ((pos (point)) + (fill-prefix " ")) + (dolist (x codings) + (princ " ") (princ x)) + (insert "\n") + (fill-region-as-paragraph pos (point))) + (insert "Or specify any other coding system +at the risk of losing the problematic characters.\n"))) + + ;; Read a coding system. + (setq coding-system + (read-coding-system + (format "Select coding system (default %s): " default) + default)) + (setq last-coding-system-specified coding-system)) + + (kill-buffer "*Warning*") + (set-window-configuration window-configuration) + coding-system)) + (defun select-safe-coding-system (from to &optional default-coding-system accept-default-p file) "Ask a user to select a safe coding system from candidates. @@ -705,7 +877,6 @@ and TO is ignored." (let ((codings (find-coding-systems-region from to)) (coding-system nil) - (bufname (buffer-name)) safe rejected unsafe) ;; Classify the defaults into safe, rejected, and unsafe. (dolist (elt default-coding-system) @@ -721,173 +892,8 @@ and TO is ignored." ;; If all the defaults failed, ask a user. (unless coding-system - ;; At first, if some defaults are unsafe, record at most 11 - ;; problematic characters and their positions for them by turning - ;; (CODING ...) - ;; into - ;; ((CODING (POS . CHAR) (POS . CHAR) ...) ...) - (if unsafe - (if (stringp from) - (setq unsafe - (mapcar #'(lambda (coding) - (cons coding - (mapcar #'(lambda (pos) - (cons pos (aref from pos))) - (unencodable-char-position - 0 (length from) coding - 11 from)))) - unsafe)) - (setq unsafe - (mapcar #'(lambda (coding) - (cons coding - (mapcar #'(lambda (pos) - (cons pos (char-after pos))) - (unencodable-char-position - from to coding 11)))) - unsafe)))) - - ;; Change each safe coding system to the corresponding - ;; mime-charset name if it is also a coding system. Such a name - ;; is more friendly to users. - (let ((l codings) - mime-charset) - (while l - (setq mime-charset (coding-system-get (car l) :mime-charset)) - (if (and mime-charset (coding-system-p mime-charset) - (coding-system-equal (car l) mime-charset)) - (setcar l mime-charset)) - (setq l (cdr l)))) - - ;; Don't offer variations with locking shift, which you - ;; basically never want. - (let (l) - (dolist (elt codings (setq codings (nreverse l))) - (unless (or (eq 'coding-category-iso-7-else - (coding-system-category elt)) - (eq 'coding-category-iso-8-else - (coding-system-category elt))) - (push elt l)))) - - ;; Remove raw-text, emacs-mule and no-conversion unless nothing - ;; else is available. - (setq codings - (or (delq 'raw-text - (delq 'emacs-mule - (delq 'no-conversion codings))) - '(raw-text emacs-mule no-conversion))) - - (let ((window-configuration (current-window-configuration))) - (save-excursion - ;; If some defaults are unsafe, make sure the offending - ;; buffer is displayed. - (when (and unsafe (not (stringp from))) - (pop-to-buffer bufname) - (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x))) - unsafe)))) - ;; Then ask users to select one from CODINGS while showing - ;; the reason why none of the defaults are not used. - (with-output-to-temp-buffer "*Warning*" - (save-excursion - (set-buffer standard-output) - (if (not default-coding-system) - (insert "No default coding systems to try for " - (if (stringp from) - (format "string \"%s\"." from) - (format "buffer `%s'." bufname))) - (insert - "These default coding systems were tried to encode" - (if (stringp from) - (concat " \"" (if (> (length from) 10) - (concat (substring from 0 10) "...\"") - (concat from "\""))) - (format " text\nin the buffer `%s'" bufname)) - ":\n") - (let ((pos (point)) - (fill-prefix " ")) - (mapc #'(lambda (x) (princ " ") (princ (car x))) - default-coding-system) - (insert "\n") - (fill-region-as-paragraph pos (point))) - (when rejected - (insert "These safely encodes the target text, -but it is not recommended for encoding text in this context, -e.g., for sending an email message.\n ") - (mapc #'(lambda (x) (princ " ") (princ x)) rejected) - (insert "\n")) - (when unsafe - (insert (if rejected "And the others" - "However, each of them") - " encountered these problematic characters:\n") - (mapc - #'(lambda (coding) - (insert (format " %s:" (car coding))) - (let ((i 0) - (func1 - #'(lambda (bufname pos) - (when (buffer-live-p (get-buffer bufname)) - (pop-to-buffer bufname) - (goto-char pos)))) - (func2 - #'(lambda (bufname pos coding) - (when (buffer-live-p (get-buffer bufname)) - (pop-to-buffer bufname) - (if (< (point) pos) - (goto-char pos) - (forward-char 1) - (search-unencodable-char coding) - (forward-char -1)))))) - (dolist (elt (cdr coding)) - (insert " ") - (if (stringp from) - (insert (if (< i 10) (cdr elt) "...")) - (if (< i 10) - (insert-text-button - (cdr elt) - :type 'help-xref - 'help-echo - "mouse-2, RET: jump to this character" - 'help-function func1 - 'help-args (list bufname (car elt))) - (insert-text-button - "..." - :type 'help-xref - 'help-echo - "mouse-2, RET: next unencodable character" - 'help-function func2 - 'help-args (list bufname (car elt) - (car coding))))) - (setq i (1+ i)))) - (insert "\n")) - unsafe) - (insert "\ -The first problematic character is at point in the displayed buffer,\n" - (substitute-command-keys "\ -and \\[universal-argument] \\[what-cursor-position] will give information about it.\n")))) - (insert (if rejected - "\nSelect the above, or " - "\nSelect ") - "\ -one of the following safe coding systems, or edit the buffer:\n") - (let ((pos (point)) - (fill-prefix " ")) - (mapcar (function (lambda (x) (princ " ") (princ x))) - codings) - (insert "\n") - (fill-region-as-paragraph pos (point))) - (insert "Or specify any other coding system -at the risk of losing the problematic characters.\n"))) - - ;; Read a coding system. - (setq default-coding-system (or (car safe) (car codings))) - (setq coding-system - (read-coding-system - (format "Select coding system (default %s): " - default-coding-system) - default-coding-system)) - (setq last-coding-system-specified coding-system)) - - (kill-buffer "*Warning*") - (set-window-configuration window-configuration))) + (setq coding-system (select-safe-coding-system-interactively + from to codings unsafe rejected (car codings)))) (if (and coding-system (vectorp (coding-system-eol-type coding-system))) (let ((eol (coding-system-eol-type buffer-file-coding-system))) @@ -1344,12 +1350,14 @@ If INPUT-METHOD is nil, deactivate any current input method." current-input-method-title nil) (force-mode-line-update))))) -(defun set-input-method (input-method) +(defun set-input-method (input-method &optional interactive) "Select and activate input method INPUT-METHOD for the current buffer. This also sets the default input method to the one you specify. If INPUT-METHOD is nil, this function turns off the input method, and also causes you to be prompted for a name of an input method the next time you invoke \\[toggle-input-method]. +When called interactively, the optional arg INTERACTIVE is non-nil, +which marks the variable `default-input-method' as set for Custom buffers. To deactivate the input method interactively, use \\[toggle-input-method]. To deactivate it programmatically, use \\[inactivate-input-method]." @@ -1357,14 +1365,15 @@ To deactivate it programmatically, use \\[inactivate-input-method]." (let* ((default (or (car input-method-history) default-input-method))) (list (read-input-method-name (if default "Select input method (default %s): " "Select input method: ") - default t)))) + default t) + t))) (activate-input-method input-method) (setq default-input-method input-method) - (when (interactive-p) + (when interactive (customize-mark-as-set 'default-input-method)) default-input-method) -(defun toggle-input-method (&optional arg) +(defun toggle-input-method (&optional arg interactive) "Enable or disable multilingual text input method for the current buffer. Only one input method can be enabled at any time in a given buffer. @@ -1377,9 +1386,12 @@ minibuffer. With a prefix argument, read an input method name with the minibuffer and enable that one. The default is the most recent input method specified -\(not including the currently active input method, if any)." +\(not including the currently active input method, if any). - (interactive "P") +When called interactively, the optional arg INTERACTIVE is non-nil, +which marks the variable `default-input-method' as set for Custom buffers." + + (interactive "P\np") (if (and current-input-method (not arg)) (inactivate-input-method) (let ((default (or (car input-method-history) default-input-method))) @@ -1396,7 +1408,7 @@ and enable that one. The default is the most recent input method specified (unless default-input-method (prog1 (setq default-input-method current-input-method) - (when (interactive-p) + (when interactive (customize-mark-as-set 'default-input-method))))))) (eval-when-compile (autoload 'help-buffer "help-mode")) @@ -1636,6 +1648,8 @@ The default status is as follows: (set-default-coding-systems nil) (setq default-sendmail-coding-system 'iso-latin-1) + ;; On Darwin systems, this should be utf-8, but when this file is loaded + ;; utf-8 is not yet defined, so we set it in set-locale-environment instead. (setq default-file-name-coding-system 'iso-latin-1) ;; Preserve eol-type from existing default-process-coding-systems. ;; On non-unix-like systems in particular, these may have been set @@ -1739,7 +1753,7 @@ specifies the character set for the major languages of Western Europe." (if (eq window-system 'pc) (setq nonascii (intern "cp%d" dos-codepage))) (or (and (charsetp nonascii) - (= (charset-dimension nonascii) 1)) + (get-charset-property nonascii :ascii-compatible-p)) (setq nonascii 'iso-8859-1)) (set-unibyte-charset nonascii)) @@ -1752,14 +1766,6 @@ specifies the character set for the major languages of Western Europe." (require (car required-features)) (setq required-features (cdr required-features)))) - ;; Don't invoke fontset-related functions if fontsets aren't - ;; supported in this build of Emacs. - (when (fboundp 'fontset-list) - (let ((overriding-fontspec (get-language-info language-name - 'overriding-fontspec))) - (if overriding-fontspec - (set-overriding-fontspec-internal overriding-fontspec)))) - (let ((func (get-language-info language-name 'setup-function))) (if (functionp func) (funcall func))) @@ -1794,7 +1800,7 @@ remove them from the language info until you next restart Emacs. Setting this variable directly does not take effect. See `set-language-info-alist' for use in programs." :group 'mule - :version "22.1" + :version "23.1" :set (lambda (s v) (custom-set-default s v) ;; Can't do this before language environments are set up. @@ -1836,12 +1842,14 @@ Setting this variable directly does not take effect. See ;; different there. (or (and (eq window-system 'pc) (not default-enable-multibyte-characters)) (progn - ;; Make non-line-break space display as a plain space. - ;; Most X fonts do the wrong thing for code 160. - (aset standard-display-table 160 [32]) - ;; With luck, non-Latin-1 fonts are more recent and so don't - ;; have this bug. - (aset standard-display-table (make-char 'latin-iso8859-1 160) [32]) + ;; Most X fonts used to do the wrong thing for latin-1 code 160. + (unless (and (eq window-system 'x) + ;; XFree86 4 has fixed the fonts. + (string= "The XFree86 Project, Inc" (x-server-vendor)) + (> (aref (number-to-string (nth 2 (x-server-version))) 0) + ?3)) + ;; Make non-line-break space display as a plain space. + (aset standard-display-table 160 [32])) ;; Most Windows programs send out apostrophes as \222. Most X fonts ;; don't contain a character at that position. Map it to the ASCII ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK, @@ -1849,23 +1857,7 @@ Setting this variable directly does not take effect. See ;; fonts probably have the appropriate glyph at this position, ;; so they could use standard-display-8bit. It's better to use a ;; proper windows-1252 coding system. --fx] - (aset standard-display-table 146 [39]) - ;; XFree86 4 has changed most of the fonts from their designed - ;; versions such that `' no longer appears as balanced quotes. - ;; Assume it has iso10646 fonts installed, so we can display - ;; balanced quotes. - (when (and (eq window-system 'x) - (string= "The XFree86 Project, Inc" (x-server-vendor)) - (> (aref (number-to-string (nth 2 (x-server-version))) 0) - ?3)) - ;; We suppress these setting for the moment because the - ;; above assumption is wrong. - ;; (aset standard-display-table ?' [?’]) - ;; (aset standard-display-table ?` [?‘]) - ;; The fonts don't have the relevant bug. - (aset standard-display-table 160 nil) - (aset standard-display-table (make-char 'latin-iso8859-1 160) - nil))))) + (aset standard-display-table 146 [39])))) (defun set-language-environment-coding-systems (language-name &optional eol-type) @@ -1921,8 +1913,7 @@ of `buffer-file-coding-system' set by this function." (setq language-name (symbol-name language-name))) (dolist (feature (get-language-info language-name 'features)) (require feature)) - (let ((doc (get-language-info language-name 'documentation)) - pos) + (let ((doc (get-language-info language-name 'documentation))) (help-setup-xref (list #'describe-language-environment language-name) (interactive-p)) (with-output-to-temp-buffer (help-buffer) @@ -2174,8 +2165,8 @@ of `buffer-file-coding-system' set by this function." ; zh_HK/BIG5-HKSCS \ ("zh.*[._]big5" . "Chinese-BIG5") - ("zh.*[._].gb18030" . "Chinese-GB18030") ; zh_CN.GB18030/GB18030 in glibc - ("zh.*[._].gbk" . "Chinese-GBK") + ("zh.*[._]gb18030" . "Chinese-GB18030") ; zh_CN.GB18030/GB18030 in glibc + ("zh.*[._]gbk" . "Chinese-GBK") ;; glibc has zh_TW.EUC-TW, with zh_TW defaulting to Big5 ("zh_tw" . "Chinese-CNS") ; glibc uses big5 ("zh_tw[._]euc-tw" . "Chinese-EUC-TW") @@ -2413,16 +2404,20 @@ See also `locale-charset-language-names', `locale-language-names', (message "Warning: Default coding system `%s' disagrees with system codeset `%s' for this locale." coding-system codeset)))))))) - ;; On Windows, override locale-coding-system, keyboard-coding-system, - ;; selection-coding-system with system codepage. + ;; On Windows, override locale-coding-system, + ;; keyboard-coding-system with system codepage. Note: + ;; selection-coding-system is already set in w32select.c. (when (boundp 'w32-ansi-code-page) (let ((code-page-coding (intern (format "cp%d" w32-ansi-code-page)))) (when (coding-system-p code-page-coding) (setq locale-coding-system code-page-coding) - (set-selection-coding-system code-page-coding) (set-keyboard-coding-system code-page-coding) (set-terminal-coding-system code-page-coding)))) + ;; On Darwin, file names are always encoded in utf-8, no matter the locale. + (when (eq system-type 'darwin) + (setq default-file-name-coding-system 'utf-8)) + ;; Default to A4 paper if we're not in a C, POSIX or US locale. ;; (See comments in Flocale_info.) (let ((locale locale) @@ -2453,32 +2448,112 @@ system codeset `%s' for this locale." coding-system codeset)))))))) 'a4)))))) nil) -;;; Character code property -(put 'char-code-property-table 'char-table-extra-slots 0) +;;; Character property + +;; Each element has the form (PROP . TABLE). +;; PROP is a symbol representing a character property. +;; TABLE is a char-table containing the property value for each character. +;; TABLE may be a name of file to load to build a char-table. +;; Don't modify this variable directly but use `define-char-code-property'. + +(defvar char-code-property-alist nil + "Alist of character property name vs char-table containing property values. +Internal use only.") + +(put 'char-code-property-table 'char-table-extra-slots 5) + +(defun define-char-code-property (name table &optional docstring) + "Define NAME as a character code property given by TABLE. +TABLE is a char-table of purpose `char-code-property-table' with +these extra slots: + 1st: NAME. + 2nd: Function to call to get a property value of a character. + It is called with three arugments CHAR, VAL, and TABLE, where + CHAR is a character, VAL is the value of (aref TABLE CHAR). + 3rd: Function to call to put a property value of a character. + It is called with the same arguments as above. + 4th: Function to call to get a description string of a property value. + It is called with one argument VALUE, a property value. + 5th: Data used by the above functions. + +TABLE may be a name of file to load to build a char-table. The +file should contain a call of `define-char-code-property' with a +char-table of the above format as the argument TABLE. + +TABLE may also be nil, in which case no property value is pre-assigned. + +Optional 3rd argment DOCSTRING is a documentation string of the property. + +See also the documentation of `get-char-code-property' and +`put-char-code-property'." + (or (symbolp name) + (error "Not a symbol: %s" name)) + (if (char-table-p table) + (or (and (eq (char-table-subtype table) 'char-code-property-table) + (eq (char-table-extra-slot table 0) name)) + (error "Invalid char-table: %s" table)) + (or (stringp table) + (error "Not a char-table nor a file name: %s" table))) + (let ((slot (assq name char-code-property-alist))) + (if slot + (setcdr slot table) + (setq char-code-property-alist + (cons (cons name table) char-code-property-alist)))) + (put name 'char-code-property-documentation docstring)) (defvar char-code-property-table (make-char-table 'char-code-property-table) "Char-table containing a property list of each character code. - +This table is used for properties not listed in `char-code-property-alist'. See also the documentation of `get-char-code-property' and `put-char-code-property'.") (defun get-char-code-property (char propname) - "Return the value of CHAR's PROPNAME property in `char-code-property-table'." - (let ((plist (aref char-code-property-table char))) - (if (listp plist) - (car (cdr (memq propname plist)))))) + "Return the value of CHAR's PROPNAME property." + (let ((slot (assq propname char-code-property-alist))) + (if slot + (let (table value func) + (if (stringp (cdr slot)) + (load (cdr slot))) + (setq table (cdr slot) + value (aref table char) + func (char-table-extra-slot table 1)) + (if (functionp func) + (setq value (funcall func char value table))) + value) + (plist-get (aref char-code-property-table char) propname)))) (defun put-char-code-property (char propname value) - "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. + "Store CHAR's PROPNAME property with VALUE. It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." - (let ((plist (aref char-code-property-table char))) - (if plist - (let ((slot (memq propname plist))) - (if slot - (setcar (cdr slot) value) - (nconc plist (list propname value)))) - (aset char-code-property-table char (list propname value))))) + (let ((slot (assq propname char-code-property-alist))) + (if slot + (let (table func) + (if (stringp (cdr slot)) + (load (cdr slot))) + (setq table (cdr slot) + func (char-table-extra-slot table 2)) + (if (functionp func) + (funcall func char value table) + (aset table char value))) + (let* ((plist (aref char-code-property-table char)) + (x (plist-put plist propname value))) + (or (eq x plist) + (aset char-code-property-table char x)))) + value)) + +(defun char-code-property-description (prop value) + "Return a description string of character property PROP's value VALUE. +If there's no description string for VALUE, return nil." + (let ((slot (assq prop char-code-property-alist))) + (if slot + (let (table func) + (if (stringp (cdr slot)) + (load (cdr slot))) + (setq table (cdr slot) + func (char-table-extra-slot table 3)) + (if (functionp func) + (funcall func value)))))) ;; Pretty description of encoded string @@ -2545,5 +2620,5 @@ If CODING-SYSTEM can't safely encode CHAR, return nil." (defvar nonascii-translation-table nil "This variable is obsolete.") -;;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc +;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc ;;; mule-cmds.el ends here