From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 30 Jan 2017 01:53:36 +0000 (-0800)
Subject: Implement \x<hex>; syntax for strings.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~32
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=086a40bd9b6517358f7320b09e98ac7f68fca7e4;p=mit-scheme.git

Implement \x<hex>; syntax for strings.
---

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index c0d5ac0e9..16078c505 100644
--- 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 bc81606da..85d8b34ea 100644
--- 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)))