[PATCH] Implement 'scm_c_bind_kwargs' to handle keyword arguments from C

[Mark H Weaver]

This patch speaks for itself.  Comments and suggestions solicited.

    Mark


>From a53f6505de29c8408a09127b96c8be6ad3d712a6 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Sat, 6 Apr 2013 13:36:24 -0400
Subject: [PATCH] Implement 'scm_c_bind_kwargs' to handle keyword arguments
 from C.

* libguile/keywords.c (scm_keyword_argument_error): New variable.
  (scm_c_bind_kwargs): New API function.

* libguile/keywords.h (SCM_KWARGS_ALLOW_OTHER_KEYS,
  SCM_KWARGS_ALLOW_REST): New API preprocessor macros.
  (scm_c_bind_kwargs): New prototype.

* doc/ref/api-data.texi (Coding With Keywords, Keyword Procedures): Add
  documentation.

* test-suite/standalone/test-scm-c-bind-kwargs.c: New file.

* test-suite/standalone/Makefile.am: Add test-scm-c-bind-kwargs test.
---
 doc/ref/api-data.texi                          |   64 ++++++++
 libguile/keywords.c                            |   67 ++++++++
 libguile/keywords.h                            |    5 +
 test-suite/standalone/Makefile.am              |    7 +
 test-suite/standalone/test-scm-c-bind-kwargs.c |  203 ++++++++++++++++++++++++
 5 files changed, 346 insertions(+)
 create mode 100644 test-suite/standalone/test-scm-c-bind-kwargs.c

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index dc1b761..cbbd63a 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -5779,6 +5779,8 @@ For further details on @code{let-keywords}, 
@code{define*} and other
 facilities provided by the @code{(ice-9 optargs)} module, see
 @ref{Optional Arguments}.
 
+To handle keyword arguments from procedures implemented in C,
+use @code{scm_c_bind_kwargs} (@pxref{Keyword Procedures}).
 
 @node Keyword Read Syntax
 @subsubsection Keyword Read Syntax
@@ -5881,6 +5883,68 @@ Equivalent to @code{scm_symbol_to_keyword 
(scm_from_latin1_symbol
 (@var{name}))}, respectively.
 @end deftypefn
 
address@hidden {C Function} void scm_c_bind_kwargs (const char *subr, SCM rest, 
int flags, @
+                                                SCM keyword1, SCM *argp1, @
+                                                @dots{}, @
+                                                SCM keywordN, SCM *argpN, @
+                                                @nicode{SCM_UNDEFINED})
+
+Extract the specified keyword arguments from @var{rest}, which is not
+modified.  If the keyword argument @var{keyword1} is present in
address@hidden with an associated value, that value is stored in the
+variable pointed to by @var{argp1}, otherwise the variable is left
+unchanged.  Similarly for the other keywords and argument pointers up to
address@hidden and @var{argpN}.  The argument list to
address@hidden must be terminated by @code{SCM_UNDEFINED}.
+
+Note that since the variables pointed to by @var{argp1} through
address@hidden are left unchanged if the associated keyword argument is not
+present, they should be initialized to their default values before
+calling @code{scm_c_bind_kwargs}.  Alternatively, you can initialize
+them to @code{SCM_UNDEFINED} before the call, and then use
address@hidden after the call to see which ones were provided.
+
+If an unrecognized keyword argument is present in @var{rest} and
address@hidden does not contain @code{SCM_KWARGS_ALLOW_OTHER_KEYS}, or if
+non-keyword arguments are present and @var{flags} does not contain
address@hidden, an exception is raised.  @var{subr} should
+be the name of the procedure receiving the keyword arguments, for
+purposes of error reporting.
+
+For example:
+
address@hidden
+SCM k_delimiter;
+SCM k_grammar;
+SCM sym_infix;
+
+SCM my_string_join (SCM strings, SCM rest)
address@hidden
+  SCM delimiter = SCM_UNDEFINED;
+  SCM grammar   = sym_infix;
+
+  scm_c_bind_kwargs ("my_string_join", rest, 0,
+                     k_delimiter, &delimiter,
+                     k_grammar, &grammar,
+                     SCM_UNDEFINED);
+
+  if (SCM_UNBNDP (delimiter))
+    delimiter = scm_from_utf8_string (" ");
+
+  return scm_string_join (strings, delimiter, grammar);
address@hidden
+
+void my_init ()
address@hidden
+  k_delimiter = scm_from_utf8_keyword ("delimiter");
+  k_grammar   = scm_from_utf8_keyword ("grammar");
+  sym_infix   = scm_from_utf8_symbol  ("infix");
+  scm_c_define_gsubr ("my-string-join", 1, 0, 1, my_string_join);
address@hidden
address@hidden example
address@hidden deftypefn
+
+
 @node Other Types
 @subsection ``Functionality-Centric'' Data Types
 
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 3b9a922..5025542 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -23,6 +23,7 @@
 #endif
 
 #include <string.h>
+#include <stdarg.h>
 
 #include "libguile/_scm.h"
 #include "libguile/async.h"
@@ -124,6 +125,72 @@ scm_from_utf8_keyword (const char *name)
   return scm_symbol_to_keyword (scm_from_utf8_symbol (name));
 }
 
+SCM_SYMBOL (scm_keyword_argument_error, "keyword-argument-error");
+
+void
+scm_c_bind_kwargs (const char *subr, SCM rest, int flags, ...)
+{
+  int allow_other_keys = flags & SCM_KWARGS_ALLOW_OTHER_KEYS;
+  int allow_rest       = flags & SCM_KWARGS_ALLOW_REST;
+  va_list va;
+
+  if (SCM_UNLIKELY (!allow_rest && scm_ilength (rest) % 2 != 0))
+    scm_error (scm_keyword_argument_error,
+               subr, "Odd length of keyword argument list",
+               SCM_EOL, SCM_BOOL_F);
+
+  while (scm_is_pair (rest))
+    {
+      SCM kw_or_arg = SCM_CAR (rest);
+      SCM tail = SCM_CDR (rest);
+
+      if (scm_is_keyword (kw_or_arg) && scm_is_pair (tail))
+        {
+          SCM kw;
+          SCM *arg_p;
+
+          va_start (va, allow_other_keys);
+          for (;;)
+            {
+              kw = va_arg (va, SCM);
+              if (SCM_UNBNDP (kw))
+                {
+                  /* KW_OR_ARG is not in the list of expected keywords.  */
+                  if (!allow_other_keys)
+                    scm_error (scm_keyword_argument_error,
+                               subr, "Unrecognized keyword",
+                               SCM_EOL, SCM_BOOL_F);
+                  break;
+                }
+              arg_p = va_arg (va, SCM *);
+              if (scm_is_eq (kw_or_arg, kw))
+                {
+                  /* We found the matching keyword.  Store the
+                     associated value and break out of the loop.  */
+                  *arg_p = SCM_CAR (tail);
+                  break;
+                }
+            }
+          va_end (va);
+
+          /* Advance REST.  */
+          rest = SCM_CDR (tail);
+        }
+      else
+        {
+          /* The next argument is not a keyword, or is a singleton
+             keyword at the end of REST.  */
+           if (!allow_rest)
+             scm_error (scm_keyword_argument_error,
+                        subr, "Invalid keyword",
+                        SCM_EOL, SCM_BOOL_F);
+
+           /* Advance REST.  */
+           rest = tail;
+        }
+    }
+}
+
 /* njrev: critical sections reviewed so far up to here */
 void
 scm_init_keywords ()
diff --git a/libguile/keywords.h b/libguile/keywords.h
index c9e6af1..734f784 100644
--- a/libguile/keywords.h
+++ b/libguile/keywords.h
@@ -41,6 +41,11 @@ SCM_API SCM scm_from_locale_keywordn (const char *name, 
size_t len);
 SCM_API SCM scm_from_latin1_keyword (const char *name);
 SCM_API SCM scm_from_utf8_keyword (const char *name);
 
+#define SCM_KWARGS_ALLOW_OTHER_KEYS  1
+#define SCM_KWARGS_ALLOW_REST        2
+
+SCM_API void scm_c_bind_kwargs (const char *subr, SCM rest, int flags, ...);
+
 SCM_INTERNAL void scm_init_keywords (void);
 
 #endif  /* SCM_KEYWORDS_H */
diff --git a/test-suite/standalone/Makefile.am 
b/test-suite/standalone/Makefile.am
index ffeafa8..c6d9e4e 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -204,6 +204,13 @@ test_scm_values_LDADD = $(LIBGUILE_LDADD)
 check_PROGRAMS += test-scm-values
 TESTS += test-scm-values
 
+# test-scm-c-bind-kwargs
+test_scm_c_bind_kwargs_SOURCES = test-scm-c-bind-kwargs.c
+test_scm_c_bind_kwargs_CFLAGS = ${test_cflags}
+test_scm_c_bind_kwargs_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-scm-c-bind-kwargs
+TESTS += test-scm-c-bind-kwargs
+
 if HAVE_SHARED_LIBRARIES
 
 # test-extensions
diff --git a/test-suite/standalone/test-scm-c-bind-kwargs.c 
b/test-suite/standalone/test-scm-c-bind-kwargs.c
new file mode 100644
index 0000000..25e44e4
--- /dev/null
+++ b/test-suite/standalone/test-scm-c-bind-kwargs.c
@@ -0,0 +1,203 @@
+/* test-scm-c-bind-kwargs.c */
+
+/* Copyright (C) 2013 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <assert.h>
+
+static SCM
+error_handler (void *data, SCM key, SCM args)
+{
+  SCM expected_args = scm_list_n (scm_from_latin1_string ("test"),
+                                  scm_from_latin1_string ((char *) data),
+                                  SCM_EOL, SCM_BOOL_F,
+                                  SCM_UNDEFINED);
+
+  assert (scm_is_eq (key, scm_from_latin1_symbol ("keyword-argument-error")));
+  assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+  return SCM_BOOL_T;
+}
+
+static SCM
+test_unrecognized_keyword (void *data)
+{
+  SCM k_foo = scm_from_latin1_keyword ("foo");
+  SCM k_bar = scm_from_latin1_keyword ("bar");
+  SCM k_baz = scm_from_latin1_keyword ("baz");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_foo, SCM_EOL,
+                                 k_baz, SCM_BOOL_T,
+                                 SCM_UNDEFINED),
+                     SCM_KWARGS_ALLOW_REST,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (0);
+}
+
+static SCM
+test_invalid_keyword (void *data)
+{
+  SCM k_foo = scm_from_latin1_keyword ("foo");
+  SCM k_bar = scm_from_latin1_keyword ("bar");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_foo, SCM_EOL,
+                                 SCM_INUM0, SCM_INUM1,
+                                 SCM_UNDEFINED),
+                     SCM_KWARGS_ALLOW_OTHER_KEYS,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (0);
+}
+
+static SCM
+test_odd_length (void *data)
+{
+  SCM k_foo = scm_from_latin1_keyword ("foo");
+  SCM k_bar = scm_from_latin1_keyword ("bar");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_foo, SCM_EOL,
+                                 SCM_INUM0,
+                                 SCM_UNDEFINED),
+                     SCM_KWARGS_ALLOW_OTHER_KEYS,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (0);
+}
+
+static void
+test_scm_c_bind_kwargs ()
+{
+  SCM k_foo = scm_from_latin1_keyword ("foo");
+  SCM k_bar = scm_from_latin1_keyword ("bar");
+  SCM k_baz = scm_from_latin1_keyword ("baz");
+  SCM arg_foo, arg_bar;
+
+  /* All kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_bar, SCM_EOL,
+                                 k_foo, SCM_BOOL_T,
+                                 SCM_UNDEFINED),
+                     0,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_BOOL_T));
+  assert (scm_is_eq (arg_bar, SCM_EOL));
+
+  /* Some kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_bar, SCM_EOL,
+                                 SCM_UNDEFINED),
+                     0,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_INUM0));
+  assert (scm_is_eq (arg_bar, SCM_EOL));
+
+  /* No kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_kwargs ("test",
+                     SCM_EOL,
+                     0,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_INUM0));
+  assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+  /* Other kwargs provided, when allowed.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (k_foo, SCM_EOL,
+                                 k_baz, SCM_BOOL_T,
+                                 SCM_UNDEFINED),
+                     SCM_KWARGS_ALLOW_OTHER_KEYS,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_EOL));
+  assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+  /* Other non-kwargs provided, when allowed.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_kwargs ("test",
+                     scm_list_n (SCM_BOOL_F,
+                                 k_foo, SCM_EOL,
+                                 SCM_INUM0,
+                                 k_bar, SCM_BOOL_T,
+                                 SCM_INUM1,
+                                 SCM_UNDEFINED),
+                     SCM_KWARGS_ALLOW_REST,
+                     k_foo, &arg_foo,
+                     k_bar, &arg_bar,
+                     SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_EOL));
+  assert (scm_is_eq (arg_bar, SCM_BOOL_T));
+
+  /* Test unrecognized keyword error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_unrecognized_keyword, NULL,
+                      error_handler, "Unrecognized keyword");
+
+  /* Test invalid keyword error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_invalid_keyword, NULL,
+                      error_handler, "Invalid keyword");
+
+  /* Test odd length error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_odd_length, NULL,
+                      error_handler, "Odd length of keyword argument list");
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+  test_scm_c_bind_kwargs ();
+}
+
+int
+main (int argc, char *argv[])
+{
+  scm_boot_guile (argc, argv, tests, NULL);
+  return 0;
+}
-- 
1.7.10.4