Reader option for R6RS hex escapes

This adds a reader option 'r6rs-hex-escapes that modifies the
behavior of numeric escapes in characters and strings.  When enabled,
variable-length character hex escapes (#\xNNN) are allowed and become
the default output format for numerically-escaped characters.  Also,
string hex escapes switch to a semicolon terminated hex escape (\xNNNN;).

* libguile/print.c (PRINT_CHAR_ESCAPE): new macro
  (iprin1): use new macro PRINT_CHAR_ESCAPE

* libguile/private-options.h (SCM_R6RS_ESCAPES_P): new #define

* libguile/read.c (scm_read_opts): add new option r6rs-hex-escapes
  (SCM_READ_HEX_ESCAPE): modify to take a terminator parameter
  (scm_read_string): parse R6RS hex string escapes
  (scm_read_character): parse R6RS hex character escapes

* test-suite/tests/chars.test (with-read-options): new procedure
  (R6RS hex escapes): new tests

* test-suite/tests/strings.test (with-read-options): new procedure
  (R6RS hex escapes): new tests

test-suite/tests/chars.test

@@ -29,6 +29,16 @@
   (cons #t "out-of-range"))
 
 
+;; Run THUNK in the context of the reader options OPTS
+(define (with-read-options opts thunk)
+  (let ((saved-options (read-options)))
+    (dynamic-wind
+        (lambda ()
+          (read-options opts))
+        thunk
+        (lambda ()
+          (read-options saved-options)))))
+
 (with-test-prefix "basic char handling"
 
   (with-test-prefix "evaluator"
@@ -313,3 +323,37 @@
        (with-output-to-string (lambda () (write #\soh)))
        "#\\soh"))))
 
+(with-test-prefix "R6RS hex escapes"
+
+  (pass-if "one-digit hex escape"
+    (eqv? (with-read-options '(r6rs-hex-escapes)
+            (lambda ()
+              (with-input-from-string "#\\xA" read)))
+          (integer->char #x0A)))
+
+  (pass-if "two-digit hex escape"
+    (eqv? (with-read-options '(r6rs-hex-escapes)
+            (lambda ()
+              (with-input-from-string "#\\xFF" read)))
+          (integer->char #xFF)))
+
+  (pass-if "four-digit hex escape"
+    (eqv? (with-read-options '(r6rs-hex-escapes)
+            (lambda ()
+              (with-input-from-string "#\\x00FF" read)))
+          (integer->char #xFF)))
+
+  (pass-if "eight-digit hex escape"
+    (eqv? (with-read-options '(r6rs-hex-escapes)
+            (lambda ()
+              (with-input-from-string "#\\x00006587" read)))
+          (integer->char #x6587)))
+  (pass-if "write R6RS escapes"
+    (string=?
+     (with-read-options '(r6rs-hex-escapes)
+       (lambda ()
+         (with-output-to-string 
+           (lambda () 
+             (write (integer->char #x80))))))
+     "#\\x80")))
+

test-suite/tests/strings.test

@@ -2,23 +2,24 @@
 ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
 ;;;;
 ;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
-;;;; 
+;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-strings)
-  #:use-module (test-suite lib))
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-1))
 
 (define exception:read-only-string
   (cons 'misc-error "^string is read-only"))
@@ -29,6 +30,16 @@
 (define exception:wrong-type-arg
   (cons #t "Wrong type"))
 
+;; Run THUNK in the context of the reader options OPTS
+(define (with-read-options opts thunk)
+  (let ((saved-options (read-options)))
+    (dynamic-wind
+        (lambda ()
+          (read-options opts))
+        thunk
+        (lambda ()
+          (read-options saved-options)))))
+
 ;; Create a string from integer char values, eg. (string-ints 65) => "A"
 (define (string-ints . args)
   (apply string (map integer->char args)))
@@ -229,6 +240,83 @@
   (pass-if "Guile extensions backslash escapes"
     (string=? "\0" (string #\nul))))
 
+
+(with-test-prefix "R6RS hex escapes"
+
+  (pass-if-exception "non-hex char in two-digit hex-escape"
+    exception:illegal-escape                     
+    (with-read-options '(r6rs-hex-escapes)
+      (lambda ()
+        (with-input-from-string "\"\\x0g;\"" read))))
+
+  (pass-if-exception "non-hex char in four-digit hex-escape"
+    exception:illegal-escape                     
+    (with-read-options '(r6rs-hex-escapes)
+      (lambda ()
+        (with-input-from-string "\"\\x000g;\"" read))))
+
+  (pass-if-exception "non-hex char in six-digit hex-escape"
+    exception:illegal-escape                     
+    (with-read-options '(r6rs-hex-escapes)
+      (lambda ()
+        (with-input-from-string "\"\\x00000g;\"" read))))
+
+  (pass-if-exception "no semicolon at termination of one-digit hex-escape"
+    exception:illegal-escape                     
+    (with-read-options '(r6rs-hex-escapes)
+      (lambda ()
+        (with-input-from-string "\"\\x0\"" read))))
+
+  (pass-if-exception "no semicolon at termination of three-digit hex-escape"
+    exception:illegal-escape                     
+    (with-read-options '(r6rs-hex-escapes)
+      (lambda ()
+        (with-input-from-string "\"\\x000\"" read))))
+
+  (pass-if "two-digit hex escape"
+    (eqv? 
+     (with-read-options '(r6rs-hex-escapes)
+       (lambda ()
+         (string-ref (with-input-from-string "\"--\\xff;--\"" read) 2)))
+     (integer->char #xff)))
+
+  (pass-if "four-digit hex escape"
+    (eqv?
+     (with-read-options '(r6rs-hex-escapes)
+       (lambda ()
+         (string-ref (with-input-from-string "\"--\\x0100;--\"" read) 2)))
+     (integer->char #x0100)))
+
+  (pass-if "six-digit hex escape"
+    (eqv? 
+     (with-read-options '(r6rs-hex-escapes)
+       (lambda ()
+         (string-ref (with-input-from-string "\"--\\x010300;--\"" read) 2)))
+     (integer->char #x010300)))
+
+  (pass-if "escaped characters match non-escaped ASCII characters"
+    (string=?
+     (with-read-options '(r6rs-hex-escapes)
+       (lambda ()
+         (with-input-from-string "\"\\x41;\\x0042;\\x000043;\"" read)))
+     "ABC"))
+
+  (pass-if "write R6RS escapes"
+    
+     (let* ((s1 (apply string 
+                       (map integer->char '(#x8 ; backspace
+                                            #x20 ; space
+                                            #x30 ; zero
+                                            #x40 ; at sign
+                                            ))))
+            (s2 (with-read-options '(r6rs-hex-escapes)
+                  (lambda ()
+                    (with-output-to-string 
+                      (lambda () (write s1)))))))
+       (lset= eqv? 
+              (string->list s2)
+              (list #\" #\\ #\x #\8 #\; #\space #\0 #\@ #\")))))
+
 ;;
 ;; string?
 ;;