New function ‘char-from-name’

This also fixes the mishandling of "\N{CJK COMPATIBILITY
IDEOGRAPH-F900}", "\N{VARIATION SELECTOR-1}", etc.
Problem reported by Eli Zaretskii in:
http://lists.gnu.org/archive/html/emacs-devel/2016-04/msg00614.html
* doc/lispref/nonascii.texi (Character Codes), etc/NEWS: Document this.
* lisp/international/mule-cmds.el (char-from-name): New function.
(read-char-by-name): Use it.  Document that "BED" is treated as
a name, not as a hexadecimal number.  Reject out-of-range integers,
floating-point numbers, and strings with trailing junk.
* src/lread.c (character_name_to_code): Call char-from-name
instead of inspecting ucs-names directly, so that we handle
computed names like "VARIATION SELECTOR-1".  Do not use an auto
string, since char-from-name might GC.
* test/src/lread-tests.el: Add tests for new behavior, and
fix some old tests that were wrong.

diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index 0e4aa86e48b60b52166cff60bbac7da2ad376df2..fd2ce3248fd53ae7e76dd2f7e20cd34687beb54e 100644 (file)
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -420,6 +420,18 @@ codepoint can have.
 @end example
 @end defun
 
 @end example
 @end defun
 

+@defun char-from-name string &optional ignore-case
+This function returns the character whose Unicode name is @var{string}.
+If @var{ignore-case} is non-@code{nil}, case is ignored in @var{string}.
+This function returns @code{nil} if @var{string} does not name a character.
+
+@example
+;; U+03A3
+(= (char-from-name "GREEK CAPITAL LETTER SIGMA") #x03A3)
+     @result{} t
+@end example
+@end defun
+

 @defun get-byte &optional pos string
 This function returns the byte at character position @var{pos} in the
 current buffer.  If the current buffer is unibyte, this is literally
 @defun get-byte &optional pos string
 This function returns the byte at character position @var{pos} in the
 current buffer.  If the current buffer is unibyte, this is literally

diff --git a/etc/NEWS b/etc/NEWS
index 6bdb648a7b0f56529666aec8de00efca408c3949..e401d2db3a9884169e7dba2cb320dd92e53820df 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -390,6 +390,10 @@ interpreting consecutive runs of numerical characters as numbers, and
 compares their numerical values.  According to this predicate,
 "foo2.png" is smaller than "foo12.png".
 
 compares their numerical values.  According to this predicate,
 "foo2.png" is smaller than "foo12.png".
 

++++
+** The new function 'char-from-name' converts a Unicode name string
+to the corresponding character code.
+

 +++
 ** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a
 Lisp object suitable for use with 'eq' and 'eql' correspondingly.  If
 +++
 ** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a
 Lisp object suitable for use with 'eq' and 'eql' correspondingly.  If

diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 8eb320acea59817032aa7554a81cb400087a6452..2ce21a8873172d5709fa4be58d754af661e8fa39 100644 (file)
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -2978,6 +2978,27 @@ on encoding."
   (let ((char (assoc name ucs-names)))
     (when char (format " (%c)" (cdr char)))))
 
   (let ((char (assoc name ucs-names)))
     (when char (format " (%c)" (cdr char)))))
 

+(defun char-from-name (string &optional ignore-case)
+  "Return a character as a number from its Unicode name STRING.
+If optional IGNORE-CASE is non-nil, ignore case in STRING.
+Return nil if STRING does not name a character."
+  (or (cdr (assoc-string string (ucs-names) ignore-case))
+      (let ((minus (string-match-p "-[0-9A-F]+\\'" string)))
+        (when minus
+          ;; Parse names like "VARIATION SELECTOR-17" and "CJK
+          ;; COMPATIBILITY IDEOGRAPH-F900" that are not in ucs-names.
+          (ignore-errors
+            (let* ((case-fold-search ignore-case)
+                   (vs (string-match-p "\\`VARIATION SELECTOR-" string))
+                   (minus-num (string-to-number (substring string minus)
+                                                (if vs 10 16)))
+                   (vs-offset (if vs (if (< minus-num -16) #xE00EF #xFDFF) 0))
+                   (code (- vs-offset minus-num))
+                   (name (get-char-code-property code 'name)))
+              (when (eq t (compare-strings string nil nil name nil nil
+                                           ignore-case))
+                code)))))))
+

 (defun read-char-by-name (prompt)
   "Read a character by its Unicode name or hex number string.
 Display PROMPT and read a string that represents a character by its
 (defun read-char-by-name (prompt)
   "Read a character by its Unicode name or hex number string.
 Display PROMPT and read a string that represents a character by its


@@ -2991,9 +3012,11 @@ preceded by an asterisk `*' and use completion, it will show all
 the characters whose names include that substring, not necessarily
 at the beginning of the name.
 
 the characters whose names include that substring, not necessarily
 at the beginning of the name.
 

-This function also accepts a hexadecimal number of Unicode code
-point or a number in hash notation, e.g. #o21430 for octal,
-#x2318 for hex, or #10r8984 for decimal."
+Accept a name like \"CIRCULATION FUNCTION\", a hexadecimal
+number like \"2A10\", or a number in hash notation (e.g.,
+\"#x2a10\" for hex, \"10r10768\" for decimal, or \"#o25020\" for
+octal).  Treat otherwise-ambiguous strings like \"BED\" (U+1F6CF)
+as names, not numbers."

   (let* ((enable-recursive-minibuffers t)
         (completion-ignore-case t)
         (input
   (let* ((enable-recursive-minibuffers t)
         (completion-ignore-case t)
         (input


@@ -3006,13 +3029,13 @@ point or a number in hash notation, e.g. #o21430 for octal,
                   (category . unicode-name))
               (complete-with-action action (ucs-names) string pred)))))
         (char
                   (category . unicode-name))
               (complete-with-action action (ucs-names) string pred)))))
         (char

-         (cond
-          ((string-match-p "\\`[0-9a-fA-F]+\\'" input)
-           (string-to-number input 16))
-          ((string-match-p "\\`#" input)
-           (read input))
-          (t
-           (cdr (assoc-string input (ucs-names) t))))))
+          (cond
+           ((char-from-name input t))
+           ((string-match-p "\\`[0-9a-fA-F]+\\'" input)
+            (ignore-errors (string-to-number input 16)))
+           ((string-match-p "\\`#\\([bBoOxX]\\|[0-9]+[rR]\\)[0-9a-zA-Z]+\\'"
+                            input)
+            (ignore-errors (read input))))))

     (unless (characterp char)
       (error "Invalid character"))
     char))
     (unless (characterp char)
       (error "Invalid character"))
     char))

diff --git a/src/lread.c b/src/lread.c
index a42c1f60c9555a2b0c7327ec0d9606af57e9f573..6e97e0796504a521ff95c50fbc8fac3e619138dd 100644 (file)
--- a/src/lread.c
+++ b/src/lread.c
@@ -2155,26 +2155,15 @@ grow_read_buffer (void)
 static int
 character_name_to_code (char const *name, ptrdiff_t name_len)
 {
 static int
 character_name_to_code (char const *name, ptrdiff_t name_len)
 {

-  Lisp_Object code;
-
-  /* Code point as U+XXXX....  */
-  if (name[0] == 'U' && name[1] == '+')
-    {
-      /* Pass the leading '+' to string_to_number, so that it
-        rejects monstrosities such as negative values.  */
-      code = string_to_number (name + 1, 16, false);
-    }
-  else
-    {
-      /* Look up the name in the table returned by 'ucs-names'.  */
-      AUTO_STRING_WITH_LEN (namestr, name, name_len);
-      Lisp_Object names = call0 (Qucs_names);
-      code = CDR (Fassoc (namestr, names));
-    }
-
-  if (! (INTEGERP (code)
-        && 0 <= XINT (code) && XINT (code) <= MAX_UNICODE_CHAR
-        && ! char_surrogate_p (XINT (code))))
+  /* For "U+XXXX", pass the leading '+' to string_to_number to reject
+     monstrosities like "U+-0000".  */
+  Lisp_Object code
+    = (name[0] == 'U' && name[1] == '+'
+       ? string_to_number (name + 1, 16, false)
+       : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt));
+
+  if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR)
+      || char_surrogate_p (XINT (code)))

     {
       AUTO_STRING (format, "\\N{%s}");
       AUTO_STRING_WITH_LEN (namestr, name, name_len);
     {
       AUTO_STRING (format, "\\N{%s}");
       AUTO_STRING_WITH_LEN (namestr, name, name_len);


@@ -4829,5 +4818,5 @@ that are loaded before your customizations are read!  */);
   DEFSYM (Qrehash_size, "rehash-size");
   DEFSYM (Qrehash_threshold, "rehash-threshold");
 
   DEFSYM (Qrehash_size, "rehash-size");
   DEFSYM (Qrehash_threshold, "rehash-threshold");
 

-  DEFSYM (Qucs_names, "ucs-names");
+  DEFSYM (Qchar_from_name, "char-from-name");

 }
 }

diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 2ebaf491120ff12aa744cade636dd7d27065f941..1a82d133a44667c7e8c22b6f73fdd6a2f735bad1 100644 (file)
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -28,15 +28,55 @@
 (ert-deftest lread-char-number ()
   (should (equal (read "?\\N{U+A817}") #xA817)))
 
 (ert-deftest lread-char-number ()
   (should (equal (read "?\\N{U+A817}") #xA817)))
 

-(ert-deftest lread-char-name ()
+(ert-deftest lread-char-name-1 ()

   (should (equal (read "?\\N{SYLOTI  NAGRI LETTER \n DHO}")
                  #xA817)))
   (should (equal (read "?\\N{SYLOTI  NAGRI LETTER \n DHO}")
                  #xA817)))

+(ert-deftest lread-char-name-2 ()
+  (should (equal (read "?\\N{BED}") #x1F6CF)))
+(ert-deftest lread-char-name-3 ()
+  (should (equal (read "?\\N{U+BED}") #xBED)))
+(ert-deftest lread-char-name-4 ()
+  (should (equal (read "?\\N{VARIATION SELECTOR-1}") #xFE00)))
+(ert-deftest lread-char-name-5 ()
+  (should (equal (read "?\\N{VARIATION SELECTOR-16}") #xFE0F)))
+(ert-deftest lread-char-name-6 ()
+  (should (equal (read "?\\N{VARIATION SELECTOR-17}") #xE0100)))
+(ert-deftest lread-char-name-7 ()
+  (should (equal (read "?\\N{VARIATION SELECTOR-256}") #xE01EF)))
+(ert-deftest lread-char-name-8 ()
+  (should (equal (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-F900}") #xF900)))
+(ert-deftest lread-char-name-9 ()
+  (should (equal (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-FAD9}") #xFAD9)))
+(ert-deftest lread-char-name-10 ()
+  (should (equal (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-2F800}") #x2F800)))
+(ert-deftest lread-char-name-11 ()
+  (should (equal (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-2FA1D}") #x2FA1D)))

 
 (ert-deftest lread-char-invalid-number ()
   (should-error (read "?\\N{U+110000}") :type 'invalid-read-syntax))
 
 
 (ert-deftest lread-char-invalid-number ()
   (should-error (read "?\\N{U+110000}") :type 'invalid-read-syntax))
 

-(ert-deftest lread-char-invalid-name ()
+(ert-deftest lread-char-invalid-name-1 ()

   (should-error (read "?\\N{DOES NOT EXIST}")) :type 'invalid-read-syntax)
   (should-error (read "?\\N{DOES NOT EXIST}")) :type 'invalid-read-syntax)

+(ert-deftest lread-char-invalid-name-2 ()
+  (should-error (read "?\\N{VARIATION SELECTOR-0}")) :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-3 ()
+  (should-error (read "?\\N{VARIATION SELECTOR-257}"))
+  :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-4 ()
+  (should-error (read "?\\N{VARIATION SELECTOR--0}"))
+  :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-5 ()
+  (should-error (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-F8FF}"))
+  :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-6 ()
+  (should-error (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-FADA}"))
+  :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-7 ()
+  (should-error (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-2F7FF}"))
+  :type 'invalid-read-syntax)
+(ert-deftest lread-char-invalid-name-8 ()
+  (should-error (read "?\\N{CJK COMPATIBILITY IDEOGRAPH-2FA1E}"))
+  :type 'invalid-read-syntax)

 
 (ert-deftest lread-char-non-ascii-name ()
   (should-error (read "?\\N{LATIN CAPITAL LETTER Ø}")
 
 (ert-deftest lread-char-non-ascii-name ()
   (should-error (read "?\\N{LATIN CAPITAL LETTER Ø}")


@@ -55,13 +95,13 @@
   (should-error (read "?\\N{U+DFFF}") :type 'invalid-read-syntax))
 
 (ert-deftest lread-string-char-number-1 ()
   (should-error (read "?\\N{U+DFFF}") :type 'invalid-read-syntax))
 
 (ert-deftest lread-string-char-number-1 ()

-  (should (equal (read "a\\N{U+A817}b") "a\uA817bx")))
+  (should (equal (read "\"a\\N{U+A817}b\"") "a\uA817b")))

 (ert-deftest lread-string-char-number-2 ()
   (should-error (read "?\\N{0.5}") :type 'invalid-read-syntax))
 (ert-deftest lread-string-char-number-3 ()
   (should-error (read "?\\N{U+-0}") :type 'invalid-read-syntax))
 
 (ert-deftest lread-string-char-name ()
 (ert-deftest lread-string-char-number-2 ()
   (should-error (read "?\\N{0.5}") :type 'invalid-read-syntax))
 (ert-deftest lread-string-char-number-3 ()
   (should-error (read "?\\N{U+-0}") :type 'invalid-read-syntax))
 
 (ert-deftest lread-string-char-name ()

-  (should (equal (read "a\\N{SYLOTI NAGRI  LETTER DHO}b") "a\uA817b")))
+  (should (equal (read "\"a\\N{SYLOTI NAGRI  LETTER DHO}b\"") "a\uA817b")))

 
 ;;; lread-tests.el ends here
 
 ;;; lread-tests.el ends here