aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ccwl/ccwl.scm130
-rw-r--r--ccwl/utils.scm18
-rw-r--r--tests/utils.scm7
3 files changed, 77 insertions, 78 deletions
diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index 37f8177..09c590c 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -101,73 +101,75 @@ association list."
;; TODO: Add fine-grained syntax checking.
(define-syntax command
(lambda (x)
- ((syntax-lambda** (#:key stdin #:key* inputs outputs run other)
- (let ((inputs
- ;; Canonicalize inputs.
- (map (lambda (x)
- (syntax-case x ()
- ((id args ...) (identifier? #'id)
- #'(id args ...))
- (id (identifier? #'id) #'(id))
- (_ (error "Invalid input:" (syntax->datum x)))))
- inputs)))
- (unless run
- (error "#:run key required in command definition" (syntax->datum x)))
- #`(make-command
- (list #,@(map (lambda (x)
- (syntax-case x ()
- ((id args ...)
- ;; Instantiate <input> object with
- ;; position and prefix.
- #`(input 'id
- #:position #,(list-index (lambda (x)
+ (syntax-case x ()
+ ((_ args ...)
+ (apply (syntax-lambda** (#:key stdin #:key* inputs outputs run other)
+ (let ((inputs
+ ;; Canonicalize inputs.
+ (map (lambda (x)
+ (syntax-case x ()
+ ((id args ...) (identifier? #'id)
+ #'(id args ...))
+ (id (identifier? #'id) #'(id))
+ (_ (error "Invalid input:" (syntax->datum x)))))
+ inputs)))
+ (unless run
+ (error "#:run key required in command definition" (syntax->datum x)))
+ #`(make-command
+ (list #,@(map (lambda (x)
+ (syntax-case x ()
+ ((id args ...)
+ ;; Instantiate <input> object with
+ ;; position and prefix.
+ #`(input 'id
+ #:position #,(list-index (lambda (x)
+ (syntax-case x ()
+ (input (identifier? #'input)
+ (eq? (syntax->datum #'id)
+ (syntax->datum #'input)))
+ ((_ input)
+ (eq? (syntax->datum #'id)
+ (syntax->datum #'input)))
+ (_ #f)))
+ run)
+ #:prefix #,(any (lambda (x)
(syntax-case x ()
- (input (identifier? #'input)
- (eq? (syntax->datum #'id)
- (syntax->datum #'input)))
- ((_ input)
- (eq? (syntax->datum #'id)
- (syntax->datum #'input)))
+ ((prefix input)
+ (and (eq? (syntax->datum #'id)
+ (syntax->datum #'input))
+ #'prefix))
(_ #f)))
run)
- #:prefix #,(any (lambda (x)
- (syntax-case x ()
- ((prefix input)
- (and (eq? (syntax->datum #'id)
- (syntax->datum #'input))
- #'prefix))
- (_ #f)))
- run)
- args ...))))
- inputs))
- (list #,@(map (lambda (x)
- ;; Instantiate <output> object.
- (syntax-case x ()
- ((id args ...) (identifier? #'id)
- #'(output 'id args ...))
- (id (identifier? #'id) #'(output 'id))
- (_ (error "Invalid output:"
- (syntax->datum x)))))
- outputs))
- (list #,@(map (lambda (x)
- (syntax-case x ()
- ;; Replace input symbol with quoted symbol.
- (input (identifier? #'input)
- #''input)
- ;; Leave string as is.
- (string-arg (string? (syntax->datum #'string-arg))
- #'string-arg)
- ;; Replace prefixed input symbol with
- ;; quoted symbol.
- ((prefix input) (and (string? (syntax->datum #'prefix))
- (identifier? #'input))
- #''input)
- (_ (error "Invalid command element:"
- (syntax->datum x)))))
- run))
- #,(and stdin #`'#,stdin)
- (list #,@other))))
- x)))
+ args ...))))
+ inputs))
+ (list #,@(map (lambda (x)
+ ;; Instantiate <output> object.
+ (syntax-case x ()
+ ((id args ...) (identifier? #'id)
+ #'(output 'id args ...))
+ (id (identifier? #'id) #'(output 'id))
+ (_ (error "Invalid output:"
+ (syntax->datum x)))))
+ outputs))
+ (list #,@(map (lambda (x)
+ (syntax-case x ()
+ ;; Replace input symbol with quoted symbol.
+ (input (identifier? #'input)
+ #''input)
+ ;; Leave string as is.
+ (string-arg (string? (syntax->datum #'string-arg))
+ #'string-arg)
+ ;; Replace prefixed input symbol with
+ ;; quoted symbol.
+ ((prefix input) (and (string? (syntax->datum #'prefix))
+ (identifier? #'input))
+ #''input)
+ (_ (error "Invalid command element:"
+ (syntax->datum x)))))
+ run))
+ #,(and stdin #`'#,stdin)
+ (list #,@other))))
+ #'(args ...))))))
(define (input=? input1 input2)
(eq? (input-id input1)
diff --git a/ccwl/utils.scm b/ccwl/utils.scm
index 14a3c4d..d6ca964 100644
--- a/ccwl/utils.scm
+++ b/ccwl/utils.scm
@@ -176,29 +176,23 @@ while that for n-ary arguments is the empty list. For example,
unary-arguments))))))))))))
(define-syntax-rule (syntax-lambda** formal-args body ...)
- "Like lambda**, but for syntax objects. syntax-lambda** varies
-slightly from lambda** in that the first identifier (or argument)
-passed to the resulting function is ignored. This is useful for
-writing macros that accept keyword arguments. For example,
+ "Like lambda**, but for syntax objects. For example,
((syntax-lambda** (a b #:key foo #:key* bar)
(list a b foo bar))
- #'(foo 1 2 #:foo 123 #:bar 1 2 3))
+ #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
=> (#'1 #'2 #'123 (#'1 #'2 #'3))
Just like lambda**, syntax-lambda** also 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))
- #'(bar 1 2 #:vale 123 #:naal 321 456))
+ (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))"
- (lambda (x)
+ (lambda args
(apply (lambda** formal-args body ...)
- (with-ellipsis :::
- (syntax-case x ()
- ((_ args :::)
- (unsyntax-keywords #'(args :::))))))))
+ (unsyntax-keywords args))))
(define (filter-mapi proc lst)
"Indexed filter-map. Like filter-map, but PROC calls are (proc item
diff --git a/tests/utils.scm b/tests/utils.scm
index bc9315d..be0e87f 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -84,13 +84,16 @@
(equal? (list #'1 #'2 #'123 (list #'1 #'2 #'3))
((syntax-lambda** (a b #:key foo #:key* bar)
(list a b foo bar))
- #'(foo 1 2 #:foo 123 #:bar 1 2 3))))
+ #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)))
+((syntax-lambda** (a b #:key foo #:key* bar)
+ (list a b foo bar))
+ #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
(test-assert "syntax-lambda** with default values"
(equal? (list #'1 #'2 #'123 9 #'(321 456) '(7) '(3 2 1))
((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1))
(list foo aal vale pal naal irandu sol))
- #'(bar 1 2 #:vale 123 #:naal 321 456))))
+ #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)))
(test-equal "filter-mapi"
'(1 3 5 7 9)
generated by cgit v1.2.3 (git 2.45.2) at 2024-12-22 23:29:42 +0000