aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ccwl/utils.scm32
-rw-r--r--tests/utils.scm15
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)