Implement SRFI-105 curly infix expressions.

* libguile/private-options.h: Add SCM_CURLY_INFIX_P macro, and increment
  SCM_N_READ_OPTIONS.

* libguile/read.c (sym_nfx, sym_bracket_list, sym_bracket_apply): New
  variables.
  (scm_read_opts): Add curly-infix reader option.  Reformat to comply
  with GNU coding standards.
  (scm_t_read_opts): Add curly_infix_p and neoteric_p fields.
  (init_read_options): Initialize new fields.
  (CHAR_IS_DELIMITER): Add '{', '}', '[', and ']' as delimiters if
  curly_infix_p is set.

  (set_port_square_brackets_p, set_port_curly_infix_p): New functions.

  (read_inner_expression): New function which contains the code that was
  previously in 'scm_read_expression'.  Handle curly braces when
  curly_infix_p is set.  If curly_infix_p is set and square_brackets_p
  is unset, follow the Kawa convention: [...] => ($bracket-list$ ...)

  (scm_read_expression): New function body to handle neoteric
  expressions where appropriate.

  (scm_read_shebang): Handle the new reader directives: '#!curly-infix'
  and the non-standard '#!curly-infix-and-bracket-lists'.

  (scm_read_sexp): Handle curly infix lists.

* module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-105 feature
  identifier.

* doc/ref/srfi-modules.texi (SRFI-105): Add stub doc for SRFI-105.

* doc/ref/api-evaluation.texi (Scheme Read): Add documentation for the
  'curly-infix' read option, and the '#!curly-infix' and
  '#!curly-infix-and-bracket-lists' reader directives.

* doc/ref/api-options.texi (Runtime Options): Add 'curly-infix' to the
  list of read options.

* test-suite/Makefile.am: Add tests/srfi-105.test.

* test-suite/tests/srfi-105.test: New file.

doc/ref/api-evaluation.texi

@@ -338,12 +338,17 @@ r6rs-hex-escapes  no    Use R6RS variable-length character and string hex escape
 square-brackets   yes   Treat `[' and `]' as parentheses, for R6RS compatibility.
 hungry-eol-escapes no   In strings, consume leading whitespace after an
                         escaped end-of-line.
+curly-infix       no    Support SRFI-105 curly infix expressions.
 @end smalllisp
 
 Note that Guile also includes a preliminary mechanism for setting read
 options on a per-port basis.  For instance, the @code{case-insensitive}
 read option is set (or unset) on the port when the reader encounters the
-@code{#!fold-case} or @code{#!no-fold-case} reader directives.  There is
+@code{#!fold-case} or @code{#!no-fold-case} reader directives.
+Similarly, the @code{#!curly-infix} reader directive sets the
+@code{curly-infix} read option on the port, and
+@code{#!curly-infix-and-bracket-lists} sets @code{curly-infix} and
+unsets @code{square-brackets} on the port (@pxref{SRFI-105}).  There is
 currently no other way to access or set the per-port read options.
 
 The boolean options may be toggled with @code{read-enable} and

doc/ref/api-options.texi

@@ -390,6 +390,7 @@ r6rs-hex-escapes  no    Use R6RS variable-length character and string hex escape
 square-brackets   yes   Treat `[' and `]' as parentheses, for R6RS compatibility.
 hungry-eol-escapes no   In strings, consume leading whitespace after an
                         escaped end-of-line.
+curly-infix       no    Support SRFI-105 curly infix expressions.
 scheme@@(guile-user) [1]> (read-enable 'case-insensitive)
 $2 = (square-brackets keywords #f case-insensitive positions)
 scheme@@(guile-user) [1]> ,q

doc/ref/srfi-modules.texi

@@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-69::                     Basic hash tables.
 * SRFI-88::                     Keyword objects.
 * SRFI-98::                     Accessing environment variables.
+* SRFI-105::                    Curly-infix expressions.
 @end menu
 
 
@@ -4469,6 +4470,56 @@ Returns the names and values of all the environment variables as an
 association list in which both the keys and the values are strings.
 @end deffn
 
+@node SRFI-105
+@subsection SRFI-105 Curly-infix expressions.
+@cindex SRFI-105
+@cindex curly-infix
+@cindex curly-infix-and-bracket-lists
+
+Guile's built-in reader includes support for SRFI-105 curly-infix
+expressions.  See @uref{http://srfi.schemers.org/srfi-105/srfi-105.html,
+the specification of SRFI-105}.  Some examples:
+
+@example
+@{n <= 5@}                @result{}  (<= n 5)
+@{a + b + c@}             @result{}  (+ a b c)
+@{a * @{b + c@}@}           @result{}  (* a (+ b c))
+@{(- a) / b@}             @result{}  (/ (- a) b)
+@{-(a) / b@}              @result{}  (/ (- a) b) as well
+@{(f a b) + (g h)@}       @result{}  (+ (f a b) (g h))
+@{f(a b) + g(h)@}         @result{}  (+ (f a b) (g h)) as well
+@{f[a b] + g(h)@}         @result{}  (+ ($bracket-apply$ f a b) (g h))
+'@{a + f(b) + x@}         @result{}  '(+ a (f b) x)
+@{length(x) >= 6@}        @result{}  (>= (length x) 6)
+@{n-1 + n-2@}             @result{}  (+ n-1 n-2)
+@{n * factorial@{n - 1@}@}  @result{}  (* n (factorial (- n 1)))
+@{@{a > 0@} and @{b >= 1@}@}  @result{}  (and (> a 0) (>= b 1))
+@{f@{n - 1@}(x)@}           @result{}  ((f (- n 1)) x)
+@{a . z@}                 @result{}  ($nfx$ a . z)
+@{a + b - c@}             @result{}  ($nfx$ a + b - c)
+@end example
+
+To enable curly-infix expressions within a file, place the reader
+directive @code{#!curly-infix} before the first use of curly-infix
+notation.  To globally enable curly-infix expressions in Guile's reader,
+set the @code{curly-infix} read option.
+
+Guile also implements the following non-standard extension to SRFI-105:
+if @code{curly-infix} is enabled and there is no other meaning assigned
+to square brackets (i.e. the @code{square-brackets} read option is
+turned off), then lists within square brackets are read as normal lists
+but with the special symbol @code{$bracket-list$} added to the front.
+To enable this combination of read options within a file, use the reader
+directive @code{#!curly-infix-and-bracket-lists}.  For example:
+
+@example
+[a b]    @result{}  ($bracket-list$ a b)
+[a . b]  @result{}  ($bracket-list$ a . b)
+@end example
+
+
+For more information on reader options, @xref{Scheme Read}.
+
 @c srfi-modules.texi ends here
 
 @c Local Variables:

libguile/private-options.h

@@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
 #define SCM_R6RS_ESCAPES_P     scm_read_opts[4].val
 #define SCM_SQUARE_BRACKETS_P  scm_read_opts[5].val
 #define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
+#define SCM_CURLY_INFIX_P      scm_read_opts[7].val
 
-#define SCM_N_READ_OPTIONS 6
+#define SCM_N_READ_OPTIONS 7
 
 #endif  /* PRIVATE_OPTIONS */ 

libguile/read.c

@@ -63,23 +63,31 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix");
 SCM_SYMBOL (scm_keyword_postfix, "postfix");
 SCM_SYMBOL (sym_nil, "nil");
 
-scm_t_option scm_read_opts[] = {
+/* SRFI-105 curly infix expression support */
-  { SCM_OPTION_BOOLEAN, "copy", 0,
+SCM_SYMBOL (sym_nfx, "$nfx$");
-    "Copy source code expressions." },
+SCM_SYMBOL (sym_bracket_list, "$bracket-list$");
-  { SCM_OPTION_BOOLEAN, "positions", 1,
+SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
-    "Record positions of source code expressions." },
+
-  { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
+scm_t_option scm_read_opts[] =
-    "Convert symbols to lower case."},
+  {
-  { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
+    { SCM_OPTION_BOOLEAN, "copy", 0,
-    "Style of keyword recognition: #f, 'prefix or 'postfix."},
+      "Copy source code expressions." },
-  { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
+    { SCM_OPTION_BOOLEAN, "positions", 1,
-    "Use R6RS variable-length character and string hex escapes."},
+      "Record positions of source code expressions." },
-  { SCM_OPTION_BOOLEAN, "square-brackets", 1,
+    { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
-    "Treat `[' and `]' as parentheses, for R6RS compatibility."},
+      "Convert symbols to lower case."},
-  { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
+    { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
-    "In strings, consume leading whitespace after an escaped end-of-line."},
+      "Style of keyword recognition: #f, 'prefix or 'postfix."},
-  { 0, },
+    { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
-};
+      "Use R6RS variable-length character and string hex escapes."},
+    { SCM_OPTION_BOOLEAN, "square-brackets", 1,
+      "Treat `[' and `]' as parentheses, for R6RS compatibility."},
+    { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
+      "In strings, consume leading whitespace after an escaped end-of-line."},
+    { SCM_OPTION_BOOLEAN, "curly-infix", 0,
+      "Support SRFI-105 curly infix expressions."},
+    { 0, },
+  };
  
 /* Internal read options structure.  This is initialized by 'scm_read'
    from the global and per-port read options, and a pointer is passed
@@ -101,6 +109,8 @@ struct t_read_opts
   unsigned int r6rs_escapes_p       : 1;
   unsigned int square_brackets_p    : 1;
   unsigned int hungry_eol_escapes_p : 1;
+  unsigned int curly_infix_p        : 1;
+  unsigned int neoteric_p           : 1;
 };
 
 typedef struct t_read_opts scm_t_read_opts;
@@ -217,7 +227,9 @@ scm_i_read_hash_procedures_set_x (SCM value)
 
 #define CHAR_IS_DELIMITER(c)                                    \
   (CHAR_IS_R5RS_DELIMITER (c)                                   \
-   || (((c) == ']' || (c) == '[') && opts->square_brackets_p))
+   || (((c) == ']' || (c) == '[') && (opts->square_brackets_p   \
+                                      || opts->curly_infix_p))  \
+   || (((c) == '}' || (c) == '{') && opts->curly_infix_p))
 
 /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
    Structure''.  */
@@ -405,7 +417,10 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
 {
   int c;
   SCM tmp, tl, ans = SCM_EOL;
-  const int terminating_char = ((chr == '[') ? ']' : ')');
+  const int curly_list_p = (chr == '{') && opts->curly_infix_p;
+  const int terminating_char = ((chr == '{') ? '}'
+                                : ((chr == '[') ? ']'
+                                   : ')'));
 
   /* Need to capture line and column numbers here. */
   long line = SCM_LINUM (port);
@@ -437,7 +452,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
     {
       SCM new_tail;
 
-      if (c == ')' || (c == ']' && opts->square_brackets_p))
+      if (c == ')' || (c == ']' && opts->square_brackets_p)
+          || ((c == '}' || c == ']') && opts->curly_infix_p))
         scm_i_input_error (FUNC_NAME, port,
                            "in pair: mismatched close paren: ~A",
                            scm_list_1 (SCM_MAKE_CHAR (c)));
@@ -454,7 +470,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
 	  if (terminating_char != c)
 	    scm_i_input_error (FUNC_NAME, port,
 			       "in pair: missing close paren", SCM_EOL);
-	  goto exit;
+	  break;
 	}
 
       new_tail = scm_cons (tmp, SCM_EOL);
@@ -462,7 +478,59 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
       tl = new_tail;
     }
 
- exit:
+  if (curly_list_p)
+    {
+      /* In addition to finding the length, 'scm_ilength' checks for
+         improper or circular lists, in which case it returns -1. */
+      int len = scm_ilength (ans);
+
+      /* The (len == 0) case is handled above */
+      if (len == 1)
+        /* Return directly to avoid re-annotating the element's source
+           location with the position of the outer brace.  Also, it
+           might not be possible to annotate the element. */
+        return scm_car (ans);  /* {e} => e */
+      else if (len == 2)
+        ;  /* Leave the list unchanged: {e1 e2} => (e1 e2) */
+      else if (len >= 3 && (len & 1))
+        {
+          /* It's a proper list whose length is odd and at least 3.  If
+             the elements at odd indices (the infix operator positions)
+             are all 'equal?', then it's a simple curly-infix list.
+             Otherwise it's a mixed curly-infix list. */
+          SCM op = scm_cadr (ans);
+
+          /* Check to see if the elements at odd indices are 'equal?' */
+          for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl))
+            {
+              if (scm_is_null (tl))
+                {
+                  /* Convert simple curly-infix list to prefix:
+                     {a <op> b <op> ...} => (<op> a b ...) */
+                  tl = ans;
+                  while (scm_is_pair (scm_cdr (tl)))
+                    {
+                      tmp = scm_cddr (tl);
+                      SCM_SETCDR (tl, tmp);
+                      tl = tmp;
+                    }
+                  ans = scm_cons (op, ans);
+                  break;
+                }
+              else if (scm_is_false (scm_equal_p (op, scm_car (tl))))
+                {
+                  /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */
+                  ans = scm_cons (sym_nfx, ans);
+                  break;
+                }
+            }
+        }
+      else
+        /* Mixed curly-infix (possibly improper) list:
+           {e . tail} => ($nfx$ e . tail) */
+        ans = scm_cons (sym_nfx, ans);
+    }
+
   return maybe_annotate_source (ans, port, opts, line, column);
 }
 #undef FUNC_NAME
@@ -1281,6 +1349,10 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
 
 static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
                                          int value);
+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 SCM
 scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
@@ -1307,6 +1379,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
             set_port_case_insensitive_p (port, opts, 1);
           else if (0 == strcmp ("no-fold-case", name))
             set_port_case_insensitive_p (port, opts, 0);
+          else if (0 == strcmp ("curly-infix", name))
+            set_port_curly_infix_p (port, opts, 1);
+          else if (0 == strcmp ("curly-infix-and-bracket-lists", name))
+            {
+              set_port_curly_infix_p (port, opts, 1);
+              set_port_square_brackets_p (port, opts, 0);
+            }
           else
             break;
 
@@ -1603,8 +1682,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
 #undef FUNC_NAME
 
 static SCM
-scm_read_expression (SCM port, scm_t_read_opts *opts)
+read_inner_expression (SCM port, scm_t_read_opts *opts)
-#define FUNC_NAME "scm_read_expression"
+#define FUNC_NAME "read_inner_expression"
 {
   while (1)
     {
@@ -1620,10 +1699,42 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
 	case ';':
 	  (void) scm_read_semicolon_comment (chr, port);
 	  break;
+        case '{':
+          if (opts->curly_infix_p)
+            {
+              if (opts->neoteric_p)
+                return scm_read_sexp (chr, port, opts);
+              else
+                {
+                  SCM expr;
+
+                  /* Enable neoteric expressions within curly braces */
+                  opts->neoteric_p = 1;
+                  expr = scm_read_sexp (chr, port, opts);
+                  opts->neoteric_p = 0;
+                  return expr;
+                }
+            }
+          else
+            return scm_read_mixed_case_symbol (chr, port, opts);
 	case '[':
-          if (!opts->square_brackets_p)
+          if (opts->square_brackets_p)
-            return (scm_read_mixed_case_symbol (chr, port, opts));
+            return scm_read_sexp (chr, port, opts);
-          /* otherwise fall through */
+          else if (opts->curly_infix_p)
+            {
+              /* The syntax of neoteric expressions requires that '[' be
+                 a delimiter when curly-infix is enabled, so it cannot
+                 be part of an unescaped symbol.  We might as well do
+                 something useful with it, so we adopt Kawa's convention:
+                 [...] => ($bracket-list$ ...) */
+              long line = SCM_LINUM (port);
+              int column = SCM_COL (port) - 1;
+              return maybe_annotate_source
+                (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
+                 port, opts, line, column);
+            }
+          else
+            return scm_read_mixed_case_symbol (chr, port, opts);
 	case '(':
 	  return (scm_read_sexp (chr, port, opts));
 	case '"':
@@ -1646,6 +1757,11 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
 	case ')':
 	  scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
 	  break;
+        case '}':
+          if (opts->curly_infix_p)
+            scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL);
+          else
+            return scm_read_mixed_case_symbol (chr, port, opts);
 	case ']':
           if (opts->square_brackets_p)
             scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL);
@@ -1670,6 +1786,74 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
 }
 #undef FUNC_NAME
 
+static SCM
+scm_read_expression (SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_read_expression"
+{
+  if (!opts->neoteric_p)
+    return read_inner_expression (port, opts);
+  else
+    {
+      long line = 0;
+      int column = 0;
+      SCM expr;
+
+      if (opts->record_positions_p)
+        {
+          /* We need to get the position of the first non-whitespace
+             character in order to correctly annotate neoteric
+             expressions.  For example, for the expression 'f(x)', the
+             first call to 'read_inner_expression' reads the 'f' (which
+             cannot be annotated), and then we later read the '(x)' and
+             use it to construct the new list (f x). */
+          int c = flush_ws (port, opts, (char *) NULL);
+          if (c == EOF)
+            return SCM_EOF_VAL;
+          scm_ungetc (c, port);
+          line = SCM_LINUM (port);
+          column = SCM_COL (port);
+        }
+
+      expr = read_inner_expression (port, opts);
+
+      /* 'expr' is the first component of the neoteric expression.  Now
+         we loop, and as long as the next character is '(', '[', or '{',
+         (without any intervening whitespace), we use it to construct a
+         new expression.  For example, f{n - 1}(x) => ((f (- n 1)) x). */
+      for (;;)
+        {
+          int chr = scm_getc (port);
+
+          if (chr == '(')
+            /* e(...) => (e ...) */
+            expr = scm_cons (expr, scm_read_sexp (chr, port, opts));
+          else if (chr == '[')
+            /* e[...] => ($bracket-apply$ e ...) */
+            expr = scm_cons (sym_bracket_apply,
+                             scm_cons (expr,
+                                       scm_read_sexp (chr, port, opts)));
+          else if (chr == '{')
+            {
+              SCM arg = scm_read_sexp (chr, port, opts);
+
+              if (scm_is_null (arg))
+                expr = scm_list_1 (expr);       /* e{} => (e) */
+              else
+                expr = scm_list_2 (expr, arg);  /* e{...} => (e {...}) */
+            }
+          else
+            {
+              if (chr != EOF)
+                scm_ungetc (chr, port);
+              break;
+            }
+          maybe_annotate_source (expr, port, opts, line, column);
+        }
+      return expr;
+    }
+}
+#undef FUNC_NAME
+
 
 /* Actual reader.  */
 
@@ -1980,8 +2164,10 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
 #define READ_OPTION_R6RS_ESCAPES_P         8
 #define READ_OPTION_SQUARE_BRACKETS_P     10
 #define READ_OPTION_HUNGRY_EOL_ESCAPES_P  12
+#define READ_OPTION_CURLY_INFIX_P         14
 
-#define READ_OPTIONS_NUM_BITS             14
+/* The total width in bits of the per-port overrides */
+#define READ_OPTIONS_NUM_BITS             16
 
 #define READ_OPTIONS_INHERIT_ALL  ((1UL << READ_OPTIONS_NUM_BITS) - 1)
 #define READ_OPTIONS_MAX_VALUE    READ_OPTIONS_INHERIT_ALL
@@ -2020,6 +2206,24 @@ set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
   set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
 }
 
+/* Set OPTS and PORT's square_brackets_p option according to VALUE. */
+static void
+set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value)
+{
+  value = !!value;
+  opts->square_brackets_p = value;
+  set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value);
+}
+
+/* Set OPTS and PORT's curly_infix_p option according to VALUE. */
+static void
+set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
+{
+  value = !!value;
+  opts->curly_infix_p = value;
+  set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
+}
+
 /* Initialize OPTS based on PORT's read options and the global read
    options. */
 static void
@@ -2067,8 +2271,11 @@ init_read_options (SCM port, scm_t_read_opts *opts)
   RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P,       r6rs_escapes_p);
   RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P,    square_brackets_p);
   RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p);
+  RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P,        curly_infix_p);
 
 #undef RESOLVE_BOOLEAN_OPTION
+
+  opts->neoteric_p = 0;
 }
 
 void

module/ice-9/boot-9.scm

@@ -3716,7 +3716,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 ;;; Currently, the following feature identifiers are supported:
 ;;;
-;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
 ;;;
 ;;; Remember to update the features list when adding more SRFIs.
 ;;;
@@ -3735,6 +3735,7 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-39  ;; parameterize
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
+    srfi-105 ;; curly infix expressions
     ))
 
 ;; This table maps module public interfaces to the list of features.

test-suite/Makefile.am

@@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-67.test			\
 	    tests/srfi-69.test			\
 	    tests/srfi-88.test			\
+	    tests/srfi-105.test			\
 	    tests/srfi-4.test			\
 	    tests/srfi-9.test			\
 	    tests/statprof.test			\

test-suite/tests/srfi-105.test

@@ -0,0 +1,240 @@
+;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2012 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-srfi-105)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-1))
+
+(define (read-string s)
+  (with-fluids ((%default-port-encoding #f))
+    (with-input-from-string s read)))
+
+(define (with-read-options opts thunk)
+  (let ((saved-options (read-options)))
+    (dynamic-wind
+        (lambda ()
+          (read-options opts))
+        thunk
+        (lambda ()
+          (read-options saved-options)))))
+
+;; Verify that curly braces are allowed in identifiers and that neoteric
+;; expressions are not recognized by default.
+(with-test-prefix "no-curly-infix"
+  (pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
+                   `(,(string->symbol "{f")
+                     (x) + g [y] +
+                     ,(string->symbol "h{z}")
+                     + [a]
+                     ,(string->symbol "}")))))
+
+#!curly-infix
+
+(with-test-prefix "curly-infix"
+  (pass-if (equal? '{n <= 5}                '(<= n 5)))
+  (pass-if (equal? '{x + 1}                 '(+ x 1)))
+  (pass-if (equal? '{a + b + c}             '(+ a b c)))
+  (pass-if (equal? '{x ,op y ,op z}         '(,op x y z)))
+  (pass-if (equal? '{x eqv? `a}             '(eqv? x `a)))
+  (pass-if (equal? '{'a eq? b}              '(eq? 'a b)))
+  (pass-if (equal? '{n-1 + n-2}             '(+ n-1 n-2)))
+  (pass-if (equal? '{a * {b + c}}           '(* a (+ b c))))
+  (pass-if (equal? '{a + {b - c}}           '(+ a (- b c))))
+  (pass-if (equal? '{{a + b} - c}           '(- (+ a b) c)))
+  (pass-if (equal? '{{a > 0} and {b >= 1}}  '(and (> a 0) (>= b 1))))
+  (pass-if (equal? '{}                      '()))
+  (pass-if (equal? '{5}                     '5))
+  (pass-if (equal? '{- x}                   '(- x)))
+  (pass-if (equal? '{length(x) >= 6}        '(>= (length x) 6)))
+  (pass-if (equal? '{f(x) + g(y) + h(z)}    '(+ (f x) (g y) (h z))))
+  (pass-if (equal? '{(f a b) + (g h)}       '(+ (f a b) (g h))))
+  (pass-if (equal? '{f(a b) + g(h)}         '(+ (f a b) (g h))))
+  (pass-if (equal? '{a + f(b) + x}          '(+ a (f b) x)))
+  (pass-if (equal? '{(- a) / b}             '(/ (- a) b)))
+  (pass-if (equal? '{-(a) / b}              '(/ (- a) b)))
+  (pass-if (equal? '{cos(q)}                '(cos q)))
+  (pass-if (equal? '{e{}}                   '(e)))
+  (pass-if (equal? '{pi{}}                  '(pi)))
+  (pass-if (equal? '{'f(x)}                 '(quote (f x))))
+
+  (pass-if (equal? '{ (f (g h(x))) }        '(f (g (h x)))))
+  (pass-if (equal? '{#(1 2 f(a) 4)}         '#(1 2 (f a) 4)))
+  (pass-if (equal? '{ (f #;g(x) h(x)) }     '(f (h x))))
+  (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x))))
+  (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x))))
+
+  (pass-if (equal? '{ (f #(g h(x))) }       '(f #(g (h x)))))
+  (pass-if (equal? '{ (f '(g h(x))) }       '(f '(g (h x)))))
+  (pass-if (equal? '{ (f `(g h(x))) }       '(f `(g (h x)))))
+  (pass-if (equal? '{ (f #'(g h(x))) }      '(f #'(g (h x)))))
+  (pass-if (equal? '{ (f #2((g) (h(x)))) }  '(f #2((g) ((h x))))))
+
+  (pass-if (equal? '{(map - ns)}            '(map - ns)))
+  (pass-if (equal? '{map(- ns)}             '(map - ns)))
+  (pass-if (equal? '{n * factorial{n - 1}}  '(* n (factorial (- n 1)))))
+  (pass-if (equal? '{2 * sin{- x}}          '(* 2 (sin (- x)))))
+
+  (pass-if (equal? '{3 + 4 +}               '($nfx$ 3 + 4 +)))
+  (pass-if (equal? '{3 + 4 + 5 +}           '($nfx$ 3 + 4 + 5 +)))
+  (pass-if (equal? '{a . z}                 '($nfx$ a . z)))
+  (pass-if (equal? '{a + b - c}             '($nfx$ a + b - c)))
+
+  (pass-if (equal? '{read(. options)}       '(read . options)))
+
+  (pass-if (equal? '{a(x)(y)}               '((a x) y)))
+  (pass-if (equal? '{x[a]}                  '($bracket-apply$ x a)))
+  (pass-if (equal? '{y[a b]}                '($bracket-apply$ y a b)))
+
+  (pass-if (equal? '{f(g(x))}               '(f (g x))))
+  (pass-if (equal? '{f(g(x) h(x))}          '(f (g x) (h x))))
+
+
+  (pass-if (equal? '{}                      '()))
+  (pass-if (equal? '{e}                     'e))
+  (pass-if (equal? '{e1 e2}                 '(e1 e2)))
+
+  (pass-if (equal? '{a . t}                 '($nfx$ a . t)))
+  (pass-if (equal? '{a b . t}               '($nfx$ a b . t)))
+  (pass-if (equal? '{a b c . t}             '($nfx$ a b c . t)))
+  (pass-if (equal? '{a b c d . t}           '($nfx$ a b c d . t)))
+  (pass-if (equal? '{a + b +}               '($nfx$ a + b +)))
+  (pass-if (equal? '{a + b + c +}           '($nfx$ a + b + c +)))
+  (pass-if (equal? '{q + r * s}             '($nfx$ q + r * s)))
+
+  ;; The following two tests will become relevant when Guile's reader
+  ;; supports datum labels, specified in SRFI-38 (External
+  ;; Representation for Data With Shared Structure).
+
+  ;;(pass-if (equal? '#1=f(#1#)               '#1=(f #1#)))
+  ;;(pass-if (equal? '#1={a + . #1#}          '($nfx$ . #1=(a + . #1#))))
+
+  (pass-if (equal? '{e()}                   '(e)))
+  (pass-if (equal? '{e{}}                   '(e)))
+  (pass-if (equal? '{e(1)}                  '(e 1)))
+  (pass-if (equal? '{e{1}}                  '(e 1)))
+  (pass-if (equal? '{e(1 2)}                '(e 1 2)))
+  (pass-if (equal? '{e{1 2}}                '(e (1 2))))
+  (pass-if (equal? '{f{n - 1}}              '(f (- n 1))))
+  (pass-if (equal? '{f{n - 1}(x)}           '((f (- n 1)) x)))
+  (pass-if (equal? '{f{n - 1}{y - 1}}       '((f (- n 1)) (- y 1))))
+  (pass-if (equal? '{f{- x}[y]}             '($bracket-apply$ (f (- x)) y)))
+  (pass-if (equal? '{g{- x}}                '(g (- x))))
+  (pass-if (equal? '{( . e)}                'e))
+
+  (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
+  (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
+  (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
+
+  ;; Verify that source position information is not recorded if not
+  ;; asked for.
+  (with-test-prefix "no positions"
+    (pass-if "simple curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " {1 + 2 + 3}")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "mixed curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " {1 + 2 * 3}")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "singleton curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " { 1.0 }")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "neoteric expression"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " { f(x) }")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column))))))
+
+  ;; Verify that source position information is properly recorded.
+  (with-test-prefix "positions"
+    (pass-if "simple curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " {1 + 2 + 3}")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 1))))
+    (pass-if "mixed curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " {1 + 2 * 3}")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 1))))
+    (pass-if "singleton curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " { 1.0 }")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 3))))
+    (pass-if "neoteric expression"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " { f(x) }")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 3)))))
+
+  ;; Verify that neoteric expressions are recognized only within curly braces.
+  (pass-if (equal? '(a(x)(y))               '(a (x) (y))))
+  (pass-if (equal? '(x[a])                  '(x [a])))
+  (pass-if (equal? '(y[a b])                '(y [a b])))
+  (pass-if (equal? '(a f{n - 1})            '(a f (- n 1))))
+  (pass-if (equal? '(a f{n - 1}(x))         '(a f (- n 1) (x))))
+  (pass-if (equal? '(a f{n - 1}[x])         '(a f (- n 1) [x])))
+  (pass-if (equal? '(a f{n - 1}{y - 1})     '(a f (- n 1) (- y 1))))
+
+  ;; Verify that bracket lists are not recognized by default.
+  (pass-if (equal? '{[]}                    '()))
+  (pass-if (equal? '{[a]}                   '(a)))
+  (pass-if (equal? '{[a b]}                 '(a b)))
+  (pass-if (equal? '{[a . b]}               '(a . b)))
+  (pass-if (equal? '[]                      '()))
+  (pass-if (equal? '[a]                     '(a)))
+  (pass-if (equal? '[a b]                   '(a b)))
+  (pass-if (equal? '[a . b]                 '(a . b))))
+
+
+#!curly-infix-and-bracket-lists
+
+(with-test-prefix "curly-infix-and-bracket-lists"
+  ;; Verify that these neoteric expressions still work properly
+  ;; when the 'square-brackets' read option is unset (which is done by
+  ;; the '#!curly-infix-and-bracket-lists' reader directive above).
+  (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
+  (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
+  (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
+
+  ;; The following expressions are not actually part of SRFI-105, but
+  ;; they are handled when the 'curly-infix' read option is set and the
+  ;; 'square-brackets' read option is unset.  This is a non-standard
+  ;; extension of SRFI-105, and follows the convention of GNU Kawa.
+  (pass-if (equal? '{[]}                    '($bracket-list$)))
+  (pass-if (equal? '{[a]}                   '($bracket-list$ a)))
+  (pass-if (equal? '{[a b]}                 '($bracket-list$ a b)))
+  (pass-if (equal? '{[a . b]}               '($bracket-list$ a . b)))
+
+  (pass-if (equal? '[]                      '($bracket-list$)))
+  (pass-if (equal? '[a]                     '($bracket-list$ a)))
+  (pass-if (equal? '[a b]                   '($bracket-list$ a b)))
+  (pass-if (equal? '[a . b]                 '($bracket-list$ a . b))))