[PATCH] Heed the reader settings implied by #!r6rs

[Andreas Rottmann <a.rottmann@gmx.at>]

When encountering the #!r6rs directive, apply the appropriate reader
settings to the port.

* libguile/read.scm (read-string-as-list): New helper procedure.
  (scm_read_shebang): Set reader options implied by the R6RS syntax
  upon encountering the #!r6rs directive.
* test-suite/tests/reader.test (per-port-read-options): Add tests for
  the #!r6rs directive.
---
 NEWS                         | 17 +++++++++++++++-
 libguile/read.c              | 40 +++++++++++++++++++++++++++++++++++--
 test-suite/tests/reader.test | 47 +++++++++++++++++++++++++++++++++++++-------
 3 files changed, 94 insertions(+), 10 deletions(-)

diff --git a/NEWS b/NEWS
index 0292dcd..8ed1b8d 100644
--- a/NEWS
+++ b/NEWS
@@ -1,10 +1,25 @@
 Guile NEWS --- history of user-visible changes.
-Copyright (C) 1996-2014 Free Software Foundation, Inc.
+Copyright (C) 1996-2015 Free Software Foundation, Inc.
 See the end for copying conditions.
 
 Please send Guile bug reports to bug-guile@gnu.org.
 
+Changes in 2.0.12 (since 2.0.11):
 
+* Notable changes
+
+** The #!r6rs directive now influences read syntax
+
+The #!r6rs directive now changes the per-port reader options to make
+Guile's reader conform more closely to the R6RS syntax. In particular:
+
+- It makes the reader case sensitive.
+- It disables the recognition of keyword syntax in conflict with the
+  R6RS (and R5RS).
+- It enables the `square-brackets', `hungry-eol-escapes' and
+  `r6rs-hex-escapes' reader options.
+
+\f
 Changes in 2.0.11 (since 2.0.10):
 
 This release fixes an embarrassing regression introduced in the C
diff --git a/libguile/read.c b/libguile/read.c
index 60a40d9..616529d 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014
+/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014, 2015
  *   Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
@@ -1421,6 +1421,12 @@ static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts,
                                         int value);
 static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts,
                                     int value);
+static void set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts,
+                                         int value);
+static void set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts,
+                                           int value);
+static void set_port_keyword_style (SCM port, scm_t_read_opts *opts,
+                                    enum t_keyword_style value);
 
 static SCM
 scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
@@ -1442,7 +1448,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
           scm_ungetc (c, port);
           name[i] = '\0';
           if (0 == strcmp ("r6rs", name))
-            ;  /* Silently ignore */
+            {
+              set_port_case_insensitive_p (port, opts, 0);
+              set_port_r6rs_hex_escapes_p (port, opts, 1);
+              set_port_square_brackets_p (port, opts, 1);
+              set_port_keyword_style (port, opts, KEYWORD_STYLE_HASH_PREFIX);
+              set_port_hungry_eol_escapes_p (port, opts, 1);
+            }
           else if (0 == strcmp ("fold-case", name))
             set_port_case_insensitive_p (port, opts, 1);
           else if (0 == strcmp ("no-fold-case", name))
@@ -2305,6 +2317,30 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
   set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
 }
 
+/* Set OPTS and PORT's r6rs_hex_escapes_p option according to VALUE. */
+static void
+set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, int value)
+{
+  value = !!value;
+  opts->r6rs_escapes_p = value;
+  set_port_read_option (port, READ_OPTION_R6RS_ESCAPES_P, value);
+}
+
+static void
+set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, int value)
+{
+  value = !!value;
+  opts->hungry_eol_escapes_p = value;
+  set_port_read_option (port, READ_OPTION_HUNGRY_EOL_ESCAPES_P, value);
+}
+
+static void
+set_port_keyword_style (SCM port, scm_t_read_opts *opts, enum t_keyword_style value)
+{
+  opts->keyword_style = value;
+  set_port_read_option (port, READ_OPTION_KEYWORD_STYLE, value);
+}
+
 /* Initialize OPTS based on PORT's read options and the global read
    options. */
 static void
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 9055e3b..cef95c6 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,6 @@
 ;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
 ;;;;
-;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2014
+;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2014, 2015
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; Jim Blandy <jimb@red-bean.com>
@@ -61,6 +61,11 @@
         (lambda ()
           (read-options saved-options)))))
 
+(define (read-string-as-list s)
+  (with-input-from-string s
+    (lambda ()
+      (unfold eof-object? values (lambda (x) (read)) (read)))))
+
 \f
 (with-test-prefix "reading"
   (pass-if "0"
@@ -433,14 +438,42 @@
     (equal? '(guile GuiLe gUIle)
             (with-read-options '(case-insensitive)
               (lambda ()
-                (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle"
-                  (lambda ()
-                    (list (read) (read) (read))))))))
+                (read-string-as-list "GUIle #!no-fold-case GuiLe gUIle")))))
   (pass-if "case-insensitive"
     (equal? '(GUIle guile guile)
-            (with-input-from-string "GUIle #!fold-case GuiLe gUIle"
-              (lambda ()
-                (list (read) (read) (read)))))))
+            (read-string-as-list "GUIle #!fold-case GuiLe gUIle")))
+  (with-test-prefix "r6rs"
+    (pass-if-equal "case sensitive"
+        '(guile GuiLe gUIle)
+      (with-read-options '(case-insensitive)
+        (lambda ()
+          (read-string-as-list "GUIle #!r6rs GuiLe gUIle"))))
+    (pass-if-equal "square brackets"
+        '((a b c) (foo 42 bar) (x . y))
+      (read-string-as-list "(a b c) #!r6rs [foo 42 bar] [x . y]"))
+    (pass-if-equal "hex string escapes"
+        '("native\x7fsyntax"
+          "\0"
+          "ascii\x7fcontrol"
+          "U\u0100BMP"
+          "U\U010402SMP")
+      (read-string-as-list (string-append "\"native\\x7fsyntax\" "
+                                          "#!r6rs "
+                                          "\"\\x0;\" "
+                                          "\"ascii\\x7f;control\" "
+                                          "\"U\\x100;BMP\" "
+                                          "\"U\\x10402;SMP\"")))
+    (with-test-prefix "keyword style"
+      (pass-if-equal "postfix disabled"
+          '(#:regular #:postfix postfix: #:regular2)
+        (with-read-options '(keywords postfix)
+          (lambda ()
+            (read-string-as-list "#:regular postfix: #!r6rs postfix: #:regular2"))))
+      (pass-if-equal "prefix disabled"
+          '(#:regular #:prefix :prefix #:regular2)
+        (with-read-options '(keywords prefix)
+          (lambda ()
+            (read-string-as-list "#:regular :prefix #!r6rs :prefix #:regular2")))))))
 
 (with-test-prefix "#;"
   (for-each
-- 
2.1.4