Implement \x<hex>; syntax for strings.

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index c0d5ac0e903d2a65913a33aa3c109a6ca68ed5f3..16078c50521c86bc3c73e4669dc21306a8fe3570 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -754,6 +754,7 @@ USA.
                            ((char-ci=? char #\r) #\return)
                            ((char-ci=? char #\f) #\page)
                            ((char-ci=? char #\a) #\bel)
+                           ((char=? char #\x) (parse-hex-scalar-value port db))
                            ((char->digit char 8) (octal->char char port db))
                            (else char)))))
               (write-char char port*)
@@ -762,6 +763,24 @@ USA.
             (write-char char port*)
             (loop))))))))
 
+(define (parse-hex-scalar-value port db)
+  (let loop ((sv 0) (chars '()))
+    (let* ((char (%read-char/no-eof port db))
+          (chars (cons char chars))
+          (lose
+           (lambda ()
+             (error:illegal-string-escape
+              (list->ustring (cons* #\\ #\x (reverse chars)))))))
+      (if (char=? #\; char)
+         (begin
+           (if (not (unicode-scalar-value? sv))
+               (lose))
+           (integer->char sv))
+         (let ((digit (char->digit char 16)))
+           (if (not digit)
+               (lose))
+           (loop (+ (* sv #x10) digit) chars))))))
+
 (define (octal->char c1 port db)
   (let ((d1 (char->digit c1 8)))
     (if (or (not d1) (fix:> d1 3))
@@ -1117,6 +1136,7 @@ USA.
 (define condition-type:illegal-hashed-object)
 (define condition-type:illegal-named-constant)
 (define condition-type:illegal-number)
+(define condition-type:illegal-string-escape)
 (define condition-type:illegal-unhash)
 (define condition-type:no-quoting-allowed)
 (define condition-type:non-shared-object)
@@ -1134,6 +1154,7 @@ USA.
 (define error:illegal-hashed-object)
 (define error:illegal-named-constant)
 (define error:illegal-number)
+(define error:illegal-string-escape)
 (define error:illegal-unhash)
 (define error:no-quoting-allowed)
 (define error:non-shared-object)
@@ -1181,6 +1202,10 @@ USA.
     (lambda (name port)
       (write-string "Ill-formed named constant: #!" port)
       (write name port)))
+  (define-parse-error (illegal-string-escape string)
+    (lambda (string port)
+      (write-string "Ill-formed string escape: " port)
+      (write-string string port)))
   (define-parse-error (illegal-number string)
     (lambda (string port)
       (write-string "Ill-formed number: " port)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index bc81606da9d262b13d96fdc0dd8c041980ed69a6..85d8b34ea8f9f6ccded19f4fba2ba58e6082ebf0 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -577,7 +577,10 @@ USA.
                                      (char=? char #\"))
                                  (*unparse-char char))
                                 (else
-                                 (*unparse-string (char->octal char)))))
+                                (*unparse-char #\x)
+                                (*unparse-string
+                                 (number->string (char->integer char) 16))
+                                (*unparse-char #\;))))
                         (loop (+ index 1)))
                       (*unparse-substring string start end*))))
               (*unparse-substring string 0 end*))
@@ -586,13 +589,6 @@ USA.
           (*unparse-char #\")))
       (*unparse-string string)))
 
-(define (char->octal char)
-  (let ((qr1 (integer-divide (char->integer char) 8)))
-    (let ((qr2 (integer-divide (integer-divide-quotient qr1) 8)))
-      (string (digit->char (integer-divide-quotient qr2) 8)
-              (digit->char (integer-divide-remainder qr2) 8)
-              (digit->char (integer-divide-remainder qr1) 8)))))
-
 (define (unparse/bit-string bit-string)
   (*unparse-string "#*")
   (let loop ((index (fix:- (bit-string-length bit-string) 1)))