From: Mark H Weaver <mhw@netris.org>
Date: Sun, 12 Jan 2014 09:36:02 +0000 (-0500)
Subject: read: Support R7RS '#true' and '#false' syntax for booleans.
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/7a329029cf898fc0b9b24252c9bb437e1ad0b1d7

read: Support R7RS '#true' and '#false' syntax for booleans.

* libguile/read.c (try_read_ci_chars): New static function.
  (scm_read_boolean, scm_read_array): Use 'try_read_ci_chars'.

* doc/ref/api-data.texi (Booleans): Update docs.

* test-suite/tests/reader.test ("reading"): Add tests.
---

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index fda76f1dc..198854bf1 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -56,6 +56,7 @@ For the documentation of such @dfn{compound} data types, see
 @tpindex Booleans
 
 The two boolean values are @code{#t} for true and @code{#f} for false.
+They can also be written as @code{#true} and @code{#false}, as per R7RS.
 
 Boolean values are returned by predicate procedures, such as the general
 equality predicates @code{eq?}, @code{eqv?} and @code{equal?}
diff --git a/libguile/read.c b/libguile/read.c
index b36ecd437..03a53aadc 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2003, 2004, 2006,
- *   2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2007, 2008, 2009, 2010, 2011, 2012, 2014 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
@@ -947,6 +947,43 @@ scm_read_semicolon_comment (int chr, SCM port)
   return SCM_UNSPECIFIED;
 }
 
+/* If the EXPECTED_CHARS are the next ones available from PORT, then
+   consume them and return 1.  Otherwise leave the port position where
+   it was and return 0.  EXPECTED_CHARS should be all lowercase, and
+   will be matched case-insensitively against the characters read from
+   PORT. */
+static int
+try_read_ci_chars (SCM port, const char *expected_chars)
+{
+  int num_chars_wanted = strlen (expected_chars);
+  int num_chars_read = 0;
+  char *chars_read = alloca (num_chars_wanted);
+  int c;
+
+  while (num_chars_read < num_chars_wanted)
+    {
+      c = scm_getc (port);
+      if (c == EOF)
+        break;
+      else if (tolower (c) != expected_chars[num_chars_read])
+        {
+          scm_ungetc (c, port);
+          break;
+        }
+      else
+        chars_read[num_chars_read++] = c;
+    }
+
+  if (num_chars_read == num_chars_wanted)
+    return 1;
+  else
+    {
+      while (num_chars_read > 0)
+        scm_ungetc (chars_read[--num_chars_read], port);
+      return 0;
+    }
+}
+
 
 /* Sharp readers, i.e. readers called after a `#' sign has been read.  */
 
@@ -957,10 +994,12 @@ scm_read_boolean (int chr, SCM port)
     {
     case 't':
     case 'T':
+      try_read_ci_chars (port, "rue");
       return SCM_BOOL_T;
 
     case 'f':
     case 'F':
+      try_read_ci_chars (port, "alse");
       return SCM_BOOL_F;
     }
 
@@ -1160,8 +1199,10 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column)
       c = scm_getc (port);
       if (c != '3' && c != '6')
 	{
-	  if (c != EOF)
-	    scm_ungetc (c, port);
+          if (c == 'a' && try_read_ci_chars (port, "lse"))
+            return SCM_BOOL_F;
+          else if (c != EOF)
+            scm_ungetc (c, port);
 	  return SCM_BOOL_F;
 	}
       rank = 1;
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 6e02255ad..448ae1bcb 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,7 @@
 ;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
 ;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011,
+;;;;   2014 Free Software Foundation, Inc.
 ;;;; Jim Blandy <jimb@red-bean.com>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -73,6 +74,14 @@
     (not (equal? (imag-part (read-string "-nan.0-1i"))
                  (imag-part (read-string "-nan.0+1i")))))
 
+  (pass-if-equal "#true"
+      '(a #t b)
+    (read-string "(a #true b)"))
+
+  (pass-if-equal "#false"
+      '(a #f b)
+    (read-string "(a #false b)"))
+
   ;; At one time the arg list for "Unknown # object: ~S" didn't make it out
   ;; of read.c.  Check that `format' can be applied to this error.
   (pass-if "error message on bad #"