Rework the character parser to handle backslash reasonably.

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index ee9a86b56d5103cbc6609bb0ffaea69e4b088a94..f1c6a23ca84e5ee26c784bde9771ac19577d919c 100644 (file)
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -215,30 +215,29 @@ USA.
 
 (define (name->char string #!optional fold-case?)
   (let ((fold-case? (if (default-object? fold-case?) #t fold-case?))
-       (parse-hex
-        (lambda (string start)
-          (let ((n (string->number string 16 #f start)))
-            (and (exact-nonnegative-integer? n)
-                 n))))
-       (lose (lambda () (error:bad-range-argument string 'NAME->CHAR))))
-    (receive (string bits) (match-bucky-bits-prefix string fold-case?)
-      (let ((end (string-length string)))
-       (if (fix:= 0 end)
-           (lose))
-       (if (fix:= 1 end)
-           (let ((char (string-ref string 0)))
-             (if (not (char-graphic? char))
-                 (lose))
-             (make-char (char-code char) bits))
-           (make-char (or (match-named-code string fold-case?)
-                          ;; R7RS syntax (not sure if -ci is right)
-                          (and (string-prefix-ci? "x" string)
-                               (parse-hex string 1))
+       (lose (lambda () (error:bad-range-argument string 'name->char))))
+    (let ((parse-hex
+          (lambda (string start)
+            (let ((cp (string->number string 16 #t start)))
+              (if (not (unicode-code-point? cp))
+                  (lose))
+              cp))))
+      (receive (string bits) (match-bucky-bits-prefix string fold-case?)
+       (let ((end (string-length string)))
+         (if (fix:= 0 end)
+             (lose))
+         (make-char (cond ((fix:= 1 end)
+                           (char-code (string-ref string 0)))
+                          ;; R7RS syntax
+                          ((char=? #\x (string-ref string 0))
+                           (parse-hex string 1))
                           ;; Non-standard syntax (Unicode style)
-                          (and (string-prefix-ci? "u+" string)
-                               (parse-hex string 2))
-                          (lose))
-                      bits))))))
+                          ((and (char-ci=? #\u (string-ref string 0))
+                                (char=? #\+ (string-ref string 1)))
+                           (parse-hex string 2))
+                          ((match-named-code string fold-case?))
+                          (else (lose)))
+                    bits))))))
 
 (define (char->name char)
   (let ((bits (char-bits char))

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 168ebec73fdb5897b23565c1d2da478eef92f67b..94cdbfaff5536247e5eedb3729ce254912ab429f 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -733,21 +733,41 @@ USA.
 
 (define (handler:char db ctx char1 char2)
   ctx char1 char2
-  (let ((char (%read-char/no-eof db)))
+  (let ((char (%read-char/no-eof db))
+       (at-end?
+        (lambda ()
+          (let ((char (%peek-char db)))
+            (or (eof-object? char)
+                (atom-delimiter? char))))))
     (cond ((or (atom-delimiter? char)
-              (let ((char (%peek-char db)))
-                (or (eof-object? char)
-                    (atom-delimiter? char))))
+              (at-end?))
           char)
-         ((char-ci=? char #\x)
-          (let* ((string (parse-atom db '()))
-                 (cp (string->number string 16 #t)))
-            (if (not (unicode-code-point? cp))
-                (error:illegal-code-point string))
-            (integer->char cp)))
+         ((char=? char #\x)
+          (let ((builder (string-builder)))
+            (let loop ()
+              (if (not (at-end?))
+                  (begin
+                    (builder (%read-char db))
+                    (loop))))
+            (let* ((string (builder))
+                   (cp (string->number string 16 #t)))
+              (if (not (unicode-code-point? cp))
+                  (error:illegal-code-point string))
+              (integer->char cp))))
          (else
-          (name->char (parse-atom db (list char))
-                      (db-fold-case? db))))))
+          (let ((builder (string-builder)))
+            (builder char)
+            (let loop ()
+              (if (not (at-end?))
+                  (begin
+                    (builder
+                     (let ((char (%read-char db)))
+                       (if (char=? #\\ char)
+                           (%read-char/no-eof db)
+                           char)))
+                    (loop))))
+            (name->char (builder)
+                        (db-fold-case? db)))))))
 \f
 (define (handler:named-constant db ctx char1 char2)
   ctx char1 char2