diff options
author | Michael Gran <spk121@yahoo.com> | 2010-01-12 21:02:41 -0800 |
---|---|---|
committer | Michael Gran <spk121@yahoo.com> | 2010-01-12 21:02:41 -0800 |
commit | dea901d66e46041f96d3d3a0f95bf0ab209387c9 (patch) | |
tree | f46c70881aac3180a26b2b716725794e3fc14269 | |
parent | 8470b3f45b48bf627642e8f41938492be4eacf2c (diff) | |
download | guile-dea901d66e46041f96d3d3a0f95bf0ab209387c9.tar.gz |
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
-rw-r--r-- | libguile/print.c | 106 | ||||
-rw-r--r-- | libguile/private-options.h | 8 | ||||
-rw-r--r-- | libguile/read.c | 88 | ||||
-rw-r--r-- | test-suite/tests/chars.test | 44 | ||||
-rw-r--r-- | test-suite/tests/strings.test | 96 |
5 files changed, 274 insertions, 68 deletions
diff --git a/libguile/print.c b/libguile/print.c index aef575d80..dcf28c7c2 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -409,6 +409,22 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); + +/* Print a character as an octal or hex escape. */ +#define PRINT_CHAR_ESCAPE(i, port) \ + do \ + { \ + if (!SCM_R6RS_ESCAPES_P) \ + scm_intprint (i, 8, port); \ + else \ + { \ + scm_puts ("x", port); \ + scm_intprint (i, 16, port); \ + } \ + } \ + while (0) + + void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -488,7 +504,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else /* Character is graphic but unrepresentable in this port's encoding. */ - scm_intprint (i, 8, port); + PRINT_CHAR_ESCAPE (i, port); } else { @@ -507,12 +523,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else /* Character is graphic but unrepresentable in this port's encoding. */ - scm_intprint (i, 8, port); + PRINT_CHAR_ESCAPE (i, port); } } else /* Character is a non-graphical character. */ - scm_intprint (i, 8, port); + PRINT_CHAR_ESCAPE (i, port); } else scm_i_charprint (i, port); @@ -579,9 +595,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_string: if (SCM_WRITINGP (pstate)) { - size_t i, j, len; + size_t i, len; static char const hex[] = "0123456789abcdef"; - char buf[8]; + char buf[9]; scm_putc ('"', port); @@ -647,37 +663,61 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) { /* Character is graphic but unrepresentable in this port's encoding or is not graphic. */ - if (ch <= 0xFF) + if (!SCM_R6RS_ESCAPES_P) { - buf[0] = '\\'; - buf[1] = 'x'; - buf[2] = hex[ch / 16]; - buf[3] = hex[ch % 16]; - scm_lfwrite (buf, 4, port); - } - else if (ch <= 0xFFFF) - { - buf[0] = '\\'; - buf[1] = 'u'; - buf[2] = hex[(ch & 0xF000) >> 12]; - buf[3] = hex[(ch & 0xF00) >> 8]; - buf[4] = hex[(ch & 0xF0) >> 4]; - buf[5] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 6, port); - j = i + 1; + if (ch <= 0xFF) + { + buf[0] = '\\'; + buf[1] = 'x'; + buf[2] = hex[ch / 16]; + buf[3] = hex[ch % 16]; + scm_lfwrite (buf, 4, port); + } + else if (ch <= 0xFFFF) + { + buf[0] = '\\'; + buf[1] = 'u'; + buf[2] = hex[(ch & 0xF000) >> 12]; + buf[3] = hex[(ch & 0xF00) >> 8]; + buf[4] = hex[(ch & 0xF0) >> 4]; + buf[5] = hex[(ch & 0xF)]; + scm_lfwrite (buf, 6, port); + } + else if (ch > 0xFFFF) + { + buf[0] = '\\'; + buf[1] = 'U'; + buf[2] = hex[(ch & 0xF00000) >> 20]; + buf[3] = hex[(ch & 0xF0000) >> 16]; + buf[4] = hex[(ch & 0xF000) >> 12]; + buf[5] = hex[(ch & 0xF00) >> 8]; + buf[6] = hex[(ch & 0xF0) >> 4]; + buf[7] = hex[(ch & 0xF)]; + scm_lfwrite (buf, 8, port); + } } - else if (ch > 0xFFFF) + else { - buf[0] = '\\'; - buf[1] = 'U'; - buf[2] = hex[(ch & 0xF00000) >> 20]; - buf[3] = hex[(ch & 0xF0000) >> 16]; - buf[4] = hex[(ch & 0xF000) >> 12]; - buf[5] = hex[(ch & 0xF00) >> 8]; - buf[6] = hex[(ch & 0xF0) >> 4]; - buf[7] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 8, port); - j = i + 1; + scm_t_wchar ch2 = ch; + + /* Print an R6RS variable-length hex escape: "\xNNNN;" + */ + int i = 8; + buf[i] = ';'; + i --; + if (ch == 0) + buf[i--] = '0'; + else + while (ch2 > 0) + { + buf[i] = hex[ch2 & 0xF]; + ch2 >>= 4; + i --; + } + buf[i] = 'x'; + i --; + buf[i] = '\\'; + scm_lfwrite (buf + i, 9 - i, port); } } } diff --git a/libguile/private-options.h b/libguile/private-options.h index 703ca8a5b..40d40fbd7 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -94,9 +94,13 @@ SCM_API scm_t_option scm_read_opts[]; #if SCM_ENABLE_ELISP #define SCM_ELISP_VECTORS_P scm_read_opts[4].val #define SCM_ESCAPED_PARENS_P scm_read_opts[5].val -#define SCM_N_READ_OPTIONS 6 +#endif +#define SCM_R6RS_ESCAPES_P scm_read_opts[6].val + +#if SCM_ENABLE_ELISP +#define SCM_N_READ_OPTIONS 7 #else -#define SCM_N_READ_OPTIONS 4 +#define SCM_N_READ_OPTIONS 5 #endif #endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index 011684b3d..9e66cce80 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -76,6 +76,8 @@ scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "elisp-strings", 0, "Support `\\(' and `\\)' in strings."}, #endif + { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0, + "Use R6RS variable-length character and string hex escapes."}, { 0, }, }; @@ -412,32 +414,37 @@ scm_read_sexp (scm_t_wchar chr, SCM port) /* Read a hexadecimal number NDIGITS in length. Put its value into the variable - C. */ -#define SCM_READ_HEX_ESCAPE(ndigits) \ - do \ - { \ - scm_t_wchar a; \ - size_t i = 0; \ - c = 0; \ - while (i < ndigits) \ - { \ - a = scm_getc (port); \ - if (a == EOF) \ - goto str_eof; \ - if ('0' <= a && a <= '9') \ - a -= '0'; \ - else if ('A' <= a && a <= 'F') \ - a = a - 'A' + 10; \ - else if ('a' <= a && a <= 'f') \ - a = a - 'a' + 10; \ - else \ - { \ - c = a; \ - goto bad_escaped; \ - } \ - c = c * 16 + a; \ - i ++; \ - } \ + C. If TERMINATOR is non-null, terminate early if the TERMINATOR character is + found. */ +#define SCM_READ_HEX_ESCAPE(ndigits, terminator) \ + do \ + { \ + scm_t_wchar a; \ + size_t i = 0; \ + c = 0; \ + while (i < ndigits) \ + { \ + a = scm_getc (port); \ + if (a == EOF) \ + goto str_eof; \ + if (terminator \ + && (a == (scm_t_wchar) terminator) \ + && (i > 0)) \ + break; \ + if ('0' <= a && a <= '9') \ + a -= '0'; \ + else if ('A' <= a && a <= 'F') \ + a = a - 'A' + 10; \ + else if ('a' <= a && a <= 'f') \ + a = a - 'a' + 10; \ + else \ + { \ + c = a; \ + goto bad_escaped; \ + } \ + c = c * 16 + a; \ + i ++; \ + } \ } while (0) static SCM @@ -511,13 +518,16 @@ scm_read_string (int chr, SCM port) c = '\010'; break; case 'x': - SCM_READ_HEX_ESCAPE (2); + if (SCM_R6RS_ESCAPES_P) + SCM_READ_HEX_ESCAPE (10, ';'); + else + SCM_READ_HEX_ESCAPE (2, '\0'); break; case 'u': - SCM_READ_HEX_ESCAPE (4); + SCM_READ_HEX_ESCAPE (4, '\0'); break; case 'U': - SCM_READ_HEX_ESCAPE (6); + SCM_READ_HEX_ESCAPE (6, '\0'); break; default: bad_escaped: @@ -828,6 +838,26 @@ scm_read_character (scm_t_wchar chr, SCM port) } } + if (cp == 'x' && (charname_len > 1) && SCM_R6RS_ESCAPES_P) + { + SCM p; + scm_t_wchar chr; + + /* Convert from hex, skipping the initial 'x' character in CHARNAME */ + p = scm_string_to_number (scm_c_substring (charname, 1, charname_len), + scm_from_uint (16)); + if (SCM_I_INUMP (p)) + { + scm_t_wchar c = SCM_I_INUM (p); + if (SCM_IS_UNICODE_CHAR (c)) + return SCM_MAKE_CHAR (c); + else + scm_i_input_error (FUNC_NAME, port, + "out-of-range hex character escape: ~a", + scm_list_1 (charname)); + } + } + /* The names of characters should never have non-Latin1 characters. */ if (scm_i_is_narrow_string (charname) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index 509f07066..25c82e825 100644 --- a/test-suite/tests/chars.test +++ b/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"))) + diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index e04c0260d..47ae93ae9 100644 --- a/test-suite/tests/strings.test +++ b/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? ;; |