From 8cb1b1972fb00245a8a24d75e51b1cd8d474d1de Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Mon, 4 Oct 2021 16:55:21 +0530
Subject: ccwl: Support #:allow-other-keys in lambda** and syntax-lambda**.

* ccwl/utils.scm (lambda**): Support #:allow-other-keys. Update
docstring.
(syntax-lambda**): Update docstring.
* tests/utils.scm ("Allow other keys in lambda**", "Allow other keys
in syntax-lambda**"): New tests.
---
 ccwl/utils.scm  | 32 +++++++++++++++++++++++++++-----
 tests/utils.scm | 15 +++++++++++++++
 2 files changed, 42 insertions(+), 5 deletions(-)

diff --git a/ccwl/utils.scm b/ccwl/utils.scm
index 4be2fe7..f7c1e14 100644
--- a/ccwl/utils.scm
+++ b/ccwl/utils.scm
@@ -144,7 +144,16 @@ while that for n-ary arguments is the empty list. For example,
 ((lambda** (foo bar #:key aal vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1) uruthi)
      (list foo bar aal vale pal naal irandu sol uruthi))
    1 2 #:vale 123 #:naal 321 456)
-=> (1 2 #f 123 9 (321 456) (7) (3 2 1) ())"
+=> (1 2 #f 123 9 (321 456) (7) (3 2 1) ())
+
+Like lambda*, lambda** supports #:allow-other-keys. For example,
+
+((lambda** (#:key foo #:allow-other-keys)
+     foo)
+   #:foo 1 #:bar 2)
+=> 1
+
+However, #:optional and #:rest are not supported."
     (syntax-case x ()
       ((_ (args-spec ...) body ...)
        #`(lambda args
@@ -154,7 +163,8 @@ while that for n-ary arguments is the empty list. For example,
                     (unary-arguments (or (plist-ref grouped-rest #:key)
                                          (list)))
                     (nary-arguments (or (plist-ref grouped-rest #:key*)
-                                        (list))))
+                                        (list)))
+                    (allow-other-keys? (plist-ref grouped-rest #:allow-other-keys)))
                (for-each (lambda (keyword)
                            (unless (memq keyword (list #:key #:key* #:allow-other-keys))
                              (scm-error 'misc-error
@@ -170,7 +180,10 @@ while that for n-ary arguments is the empty list. For example,
                                                     ((arg defaults ...)
                                                      #'(arg (list defaults ...)))
                                                     (arg #'(arg '()))))
-                                                nary-arguments))
+                                                nary-arguments)
+                                           (if allow-other-keys?
+                                               (list #:allow-other-keys)
+                                               (list)))
                           body ...)
                         (let ((positionals rest (break keyword? args)))
                           (append positionals
@@ -191,13 +204,22 @@ while that for n-ary arguments is the empty list. For example,
  #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
 => (#'1 #'2 #'123 (#'1 #'2 #'3))
 
-Just like lambda**, syntax-lambda** also supports default values for
+Like lambda**, syntax-lambda** supports default values for
 arguments. For example,
 
 ((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1))
    (list foo aal vale pal naal irandu sol))
  #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)
-=> (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1))"
+=> (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1))
+
+Like lambda**, syntax-lambda** supports #:allow-other-keys.
+
+((syntax-lambda** (#:key foo #:allow-other-keys)
+     foo)
+   #'#:foo #'1 #'#:bar #'2)
+=> #'1
+
+#:optional and #:rest are not supported."
   (lambda args
     (apply (lambda** formal-args body ...)
            (unsyntax-keywords args))))
diff --git a/tests/utils.scm b/tests/utils.scm
index a123719..3c8fac4 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -85,6 +85,12 @@
    '(lambda** (#:key foo #:foo bar)
       foo)))
 
+(test-equal "Allow other keys in lambda**"
+  1
+  ((lambda** (#:key foo #:allow-other-keys)
+     foo)
+   #:foo 1 #:bar 2))
+
 (test-assert "syntax-lambda**"
   (equal? (list #'1 #'2 #'123 (list #'1 #'2 #'3))
           ((syntax-lambda** (a b #:key foo #:key* bar)
@@ -97,6 +103,15 @@
              (list foo aal vale pal naal irandu sol))
            #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)))
 
+;; We cannot use test-equal to compare syntax objects, since
+;; test-equal does not preserve the lexical contexts of the test
+;; expressions.
+(test-assert "Allow other keys in syntax-lambda**"
+  (equal? #'1
+          ((syntax-lambda** (#:key foo #:allow-other-keys)
+             foo)
+           #'#:foo #'1 #'#:bar #'2)))
+
 (test-equal "filter-mapi"
   '(1 3 5 7 9)
   (filter-mapi (lambda (item index)
-- 
cgit v1.2.3